File Coverage

blib/lib/PHP/Serialization.pm

Criterion	Covered	Total	%
statement	188	225	83.5
branch	69	106	65.0
condition	21	36	58.3
subroutine	20	21	95.2
pod	4	5	80.0
total	302	393	76.8

package PHP::Serialization;
use strict;
use warnings;
use Exporter ();
use Scalar::Util qw/blessed/;
use Carp qw(croak confess carp);
use bytes;

use vars qw/$VERSION @ISA @EXPORT_OK/;

$VERSION = '0.34';

@ISA = qw(Exporter);
@EXPORT_OK = qw(unserialize serialize);

=head1 NAME

PHP::Serialization - simple flexible means of converting the output of PHP's serialize() into the equivalent Perl memory structure, and vice versa.

=head1 SYNOPSIS

    use PHP::Serialization qw(serialize unserialize);
    my $encoded = serialize({ a => 1, b => 2});
    my $hashref = unserialize($encoded);

=cut


=head1 DESCRIPTION

Provides a simple, quick means of serializing perl memory structures (including object data!) into a format that PHP can deserialize() and access, and vice versa.

NOTE: Converts PHP arrays into Perl Arrays when the PHP array used exclusively numeric indexes, and into Perl Hashes then the PHP array did not.

=cut

sub new {
    my ($class) = shift;
    my $self = bless {}, blessed($class) ? blessed($class) : $class;
    return $self;
}

=head1 FUNCTIONS

Exportable functions..

=cut

=head2 serialize($var,[optional $asString,[optional $sortHashes]])

Serializes the memory structure pointed to by $var, and returns a scalar value of encoded data.

If the optional $asString is true, $var will be encoded as string if it is double or float.

If the optional $sortHashes is true, all hashes will be sorted before serialization.

NOTE: Will recursively encode objects, hashes, arrays, etc.

SEE ALSO: ->encode()

=cut

sub serialize {
    return __PACKAGE__->new->encode(@_);
}

=head2 unserialize($encoded,[optional CLASS])

Deserializes the encoded data in $encoded, and returns a value (be it a hashref, arrayref, scalar, etc)
representing the data structure serialized in $encoded_string.

If the optional CLASS is specified, any objects are blessed into CLASS::$serialized_class. Otherwise, O
bjects are blessed into PHP::Serialization::Object::$serialized_class. (which has no methods)

SEE ALSO: ->decode()

=cut

sub unserialize {
    return __PACKAGE__->new->decode(@_);
}

=head1 METHODS

Functionality available if using the object interface..

=cut

=head2 decode($encoded_string,[optional CLASS])

Deserializes the encoded data in $encoded, and returns a value (be it a hashref, arrayref, scalar, etc)
representing the data structure serialized in $encoded_string.

If the optional CLASS is specified, any objects are blessed into CLASS::$serialized_class. Otherwise,
Objects are blessed into PHP::Serialization::Object::$serialized_class. (which has no methods)

SEE ALSO: unserialize()

=cut

my $sorthash;

sub decode {
    my ($self, $string, $class, $shash) = @_;
    $sorthash=$shash if defined($shash);

    my $cursor = 0;
    $self->{string} = \$string;
    $self->{cursor} = \$cursor;
    $self->{strlen} = length($string);

    if ( defined $class ) {
        $self->{class} = $class;
    }
    else {
        $self->{class} = 'PHP::Serialization::Object';
    }

    # Ok, start parsing...
    my @values = $self->_parse();

    # Ok, we SHOULD only have one value..
    if ( $#values == -1 ) {
        # Oops, none...
        return;
    }
    elsif ( $#values == 0 ) {
        # Ok, return our one value..
        return $values[0];
    }
    else {
        # Ok, return a reference to the list.
        return \@values;
    }

} # End of decode sub.

my %type_table = (
    O => 'object',
    s => 'scalar',
    a => 'array',
    i => 'integer',
    d => 'float',
    b => 'boolean',
    N => 'undef',
);

sub _parse_array {
    my $self = shift;
    my $elemcount = shift;
    my $cursor = $self->{cursor};
    my $string = $self->{string};
    my $strlen = $self->{strlen};
    confess("No cursor") unless $cursor;
    confess("No string") unless $string;
    confess("No strlen") unless $strlen;

    my @elems = ();
    my @shash_arr = ('some') if (($sorthash) and (ref($sorthash) eq 'HASH'));

    $self->_skipchar('{');
    foreach my $i (1..$elemcount*2) {
	push(@elems,$self->_parse_elem);
	if (($i % 2) and (@shash_arr)) {
	    $shash_arr[0]= ((($i-1)/2) eq $elems[$#elems])? 'array' : 'hash' unless ($shash_arr[0] eq 'hash');
	    push(@shash_arr,$elems[$#elems]);
	}
    }
    $self->_skipchar('}');
    push(@elems,\@shash_arr) if (@shash_arr);
    return @elems;
}

sub _parse_elem {
    my $self = shift;
    my $cursor = $self->{cursor};
    my $string = $self->{string};
    my $strlen = $self->{strlen};

    my @elems;

    my $type_c = $self->_readchar();
    my $type = $type_table{$type_c};
    if (!defined $type) {
        croak("ERROR: Unknown type $type_c.");
    }

    if ( $type eq 'object' ) {
        $self->_skipchar(':');
        # Ok, get our name count...
        my $namelen = $self->_readnum();
        $self->_skipchar(':');

        # Ok, get our object name...
        $self->_skipchar('"');
        my $name = $self->_readstr($namelen);
        $self->_skipchar('"');

        # Ok, our sub elements...
        $self->_skipchar(':');
        my $elemcount = $self->_readnum();
        $self->_skipchar(':');

        my %value = $self->_parse_array($elemcount);

        # TODO: Call wakeup
        # TODO: Support for objecttypes
        return bless(\%value, $self->{class} . '::' . $name);
    } elsif ( $type eq 'array' ) {
        $self->_skipchar(':');
        # Ok, our sub elements...
        my $elemcount = $self->_readnum();
        $self->_skipchar(':');

        my @values = $self->_parse_array($elemcount);
        # If every other key is not numeric, map to a hash..
        my $subtype = 'array';
        my @newlist;
	my @shash_arr=@{pop(@values)} if (ref($sorthash) eq 'HASH');
        foreach ( 0..$#values ) {
            if ( ($_ % 2) ) {
                push(@newlist, $values[$_]);
                next;
            } elsif (($_ / 2) ne $values[$_]) {
                $subtype = 'hash';
                last;
            }
            if ( $values[$_] !~ /^\d+$/ ) {
                $subtype = 'hash';
                last;
            }
        }
        if ( $subtype eq 'array' ) {
            # Ok, remap...
            return \@newlist;
        } else {
            # Ok, force into hash..
            my %hash = @values;
	    ${$sorthash}{\%hash}=@shash_arr if ((ref($sorthash) eq 'HASH') and @shash_arr and (shift(@shash_arr) ne 'array'));
            return \%hash;
        }
    }
    elsif ( $type eq 'scalar' ) {
        $self->_skipchar(':');
        # Ok, get our string size count...
        my $strlen = $self->_readnum;
        $self->_skipchar(':');

        $self->_skipchar('"');
        my $string = $self->_readstr($strlen);
        $self->_skipchar('"');
        $self->_skipchar(';');
        return $string;
    }
    elsif ( $type eq 'integer' || $type eq 'float' ) {
        $self->_skipchar(':');
        # Ok, read the value..
        my $val = $self->_readnum;
        if ( $type eq 'integer' ) { $val = int($val); }
        $self->_skipchar(';');
        return $val;
    }
    elsif ( $type eq 'boolean' ) {
        $self->_skipchar(':');
        # Ok, read our boolen value..
        my $bool = $self->_readchar;

        $self->_skipchar;
        if ($bool eq '0') {
            $bool = undef;
        }
        return $bool;
    }
    elsif ( $type eq 'undef' ) {
        $self->_skipchar(';');
        return undef;
    }
    else {
        confess "Unknown element type '$type' found! (cursor $$cursor)";
    }

}


sub _parse {
    my ($self) = @_;
    my $cursor = $self->{cursor};
    my $string = $self->{string};
    my $strlen = $self->{strlen};
    confess("No cursor") unless $cursor;
    confess("No string") unless $string;
    confess("No strlen") unless $strlen;
    my @elems;
    push(@elems,$self->_parse_elem);

    # warn if we have unused chars
    if ($$cursor != $strlen) {
        carp("WARN: Unused characters in string after $$cursor.");
    }
    return @elems;

} # End of decode.

sub _readstr {
    my ($self, $length) = @_;
    my $string = $self->{string};
    my $cursor = $self->{cursor};
    if ($$cursor + $length > length($$string)) {
        croak("ERROR: Read past end of string. Want $length after $$cursor. (".$$string.")");
    }
    my $str = substr($$string, $$cursor, $length);
    $$cursor += $length;

    return $str;
}

sub _readchar {
    my ($self) = @_;
    return $self->_readstr(1);
}

sub _readnum {
    # Reads in a character at a time until we run out of numbers to read...
    my ($self) = @_;
    my $cursor = $self->{cursor};

    my $string;
    while ( 1 ) {
        my $char = $self->_readchar;
        if ( $char !~ /^[\d\.-]+$/ ) {
            $$cursor--;
            last;
        }
        $string .= $char;
    } # End of while.

    return $string;
} # End of readnum

sub _skipchar {
    my $self = shift;
    my $want = shift;
    my $c = $self->_readchar();
    if (($want)&&($c ne $want)) {
        my $cursor = $self->{cursor};
        my $str = $self->{string};
        croak("ERROR: Wrong char $c, expected $want at position ".$$cursor." (".$$str.")");
    }
    print "_skipchar: WRONG char $c ($want)\n" if (($want)&&($c ne $want));
    # ${$$self{cursor}}++;
} # Move our cursor one bytes ahead...


=head2 encode($reference,[optional $asString,[optional $sortHashes]])

Serializes the memory structure pointed to by $reference, and returns a scalar value of encoded data.

If the optional $asString is true, $reference will be encoded as string if it is double or float.

If the optional $sortHashes is true, all hashes will be sorted before serialization.

NOTE: Will recursively encode objects, hashes, arrays, etc.

SEE ALSO: serialize()

=cut

sub encode {
    my ($self, $val, $iskey, $shash) = @_;
    $iskey=0 unless defined $iskey;
    $sorthash=$shash if defined $shash;

    if ( ! defined $val ) {
        return $self->_encode('null', $val);
    }
    elsif ( blessed $val ) {
        return $self->_encode('obj', $val);
    }
    elsif ( ! ref($val) ) {
        if ( $val =~ /^-?(?:[0-9]|[1-9]\d{1,10})$/ && abs($val) < 2**31 ) {
            return $self->_encode('int', $val);
        }
        elsif ( $val =~ /^-?\d+\.\d*$/ && !$iskey) {
            return $self->_encode('float', $val);
        }
        else {
            return $self->_encode('string', $val);
        }
    }
    else {
        my $type = ref($val);
        if ($type eq 'HASH' || $type eq 'ARRAY' ) {
            return $self->_sort_hash_encode($val) if (($sorthash) and ($type eq 'HASH'));
            return $self->_encode('array', $val);
        }
        else {
            confess "I can't serialize data of type '$type'!";
        }
    }
}

sub _sort_hash_encode {
    my ($self, $val) = @_;

    my $buffer = '';
    my @hsort = ((ref($sorthash) eq 'HASH') and (ref(${$sorthash}{$val}) eq 'ARRAY')) ? ${$sorthash}{$val} : sort keys %{$val};
    $buffer .= sprintf('a:%d:',scalar(@hsort)) . '{';
    for (@hsort) {
        $buffer .= $self->encode($_,1);
        $buffer .= $self->encode($$val{$_});
    }
    $buffer .= '}';
    return $buffer;
}

sub _encode {
    my ($self, $type, $val) = @_;

    my $buffer = '';
    if ( $type eq 'null' ) {
        $buffer .= 'N;';
    }
    elsif ( $type eq 'int' ) {
        $buffer .= sprintf('i:%d;', $val);
    }
    elsif ( $type eq 'float' ) {
        $buffer .= sprintf('d:%s;', $val);
    }
    elsif ( $type eq 'string' ) {
        $buffer .= sprintf('s:%d:"%s";', length($val), $val);
    }
    elsif ( $type eq 'array' ) {
        if ( ref($val) eq 'ARRAY' ) {
            $buffer .= sprintf('a:%d:',($#{$val}+1)) . '{';
            map { # Ewww
                $buffer .= $self->encode($_);
                $buffer .= $self->encode($$val[$_]);
            } 0..$#{$val};
            $buffer .= '}';
        }
        else {
            $buffer .= sprintf('a:%d:',scalar(keys(%{$val}))) . '{';
             while ( my ($key, $value) = each(%{$val}) ) {
                 $buffer .= $self->encode($key,1);
                 $buffer .= $self->encode($value);
            }
            $buffer .= '}';
        }
    }
    elsif ( $type eq 'obj' ) {
        my $class = ref($val);
        $class =~ /(\w+)$/;
        my $subclass = $1;
        $buffer .= sprintf('O:%d:"%s":%d:', length($subclass), $subclass, scalar(keys %{$val})) . '{';
        foreach ( %{$val} ) {
            $buffer .= $self->encode($_);
        }
        $buffer .= '}';
    }
    else {
        confess "Unknown encode type!";
    }
    return $buffer;

}

=head1 TODO

Support diffrent object types

=head1 AUTHOR INFORMATION

Copyright (c) 2003 Jesse Brown . All rights reserved. This program is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.

Various patches contributed by assorted authors on rt.cpan.org (as detailed in Changes file).

Currently maintained by Tomas Doran .

Rewritten to solve all known bugs by Bjørn-Olav Strand

=cut

package PHP::Serialization::Object;

1;