local-lib5/lib/perl5/PHP/Serialization.pm

   1 package PHP::Serialization;
   2 use strict;
   3 use warnings;
   4 use Exporter ();
   5 use Scalar::Util qw/blessed/;
   6 use Carp qw(croak confess carp);
   7 use bytes;
   8
   9 use vars qw/$VERSION @ISA @EXPORT_OK/;
  10
  11 $VERSION = '0.34';
  12
  13 @ISA = qw(Exporter);
  14 @EXPORT_OK = qw(unserialize serialize);
  15
  16 =head1 NAME
  17
  18 PHP::Serialization - simple flexible means of converting the output of PHP's serialize() into the equivalent Perl memory structure, and vice versa.
  19
  20 =head1 SYNOPSIS
  21
  22     use PHP::Serialization qw(serialize unserialize);
  23     my $encoded = serialize({ a => 1, b => 2});
  24     my $hashref = unserialize($encoded);
  25
  26 =cut
  27
  28
  29 =head1 DESCRIPTION
  30
  31 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.
  32
  33 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.
  34
  35 =cut
  36
  37 sub new {
  38     my ($class) = shift;
  39     my $self = bless {}, blessed($class) ? blessed($class) : $class;
  40     return $self;
  41 }
  42
  43 =head1 FUNCTIONS
  44
  45 Exportable functions..
  46
  47 =cut
  48
  49 =head2 serialize($var,[optional $asString,[optional $sortHashes]])
  50
  51 Serializes the memory structure pointed to by $var, and returns a scalar value of encoded data.
  52
  53 If the optional $asString is true, $var will be encoded as string if it is double or float.
  54
  55 If the optional $sortHashes is true, all hashes will be sorted before serialization.
  56
  57 NOTE: Will recursively encode objects, hashes, arrays, etc.
  58
  59 SEE ALSO: ->encode()
  60
  61 =cut
  62
  63 sub serialize {
  64     return __PACKAGE__->new->encode(@_);
  65 }
  66
  67 =head2 unserialize($encoded,[optional CLASS])
  68
  69 Deserializes the encoded data in $encoded, and returns a value (be it a hashref, arrayref, scalar, etc)
  70 representing the data structure serialized in $encoded_string.
  71
  72 If the optional CLASS is specified, any objects are blessed into CLASS::$serialized_class. Otherwise, O
  73 bjects are blessed into PHP::Serialization::Object::$serialized_class. (which has no methods)
  74
  75 SEE ALSO: ->decode()
  76
  77 =cut
  78
  79 sub unserialize {
  80     return __PACKAGE__->new->decode(@_);
  81 }
  82
  83 =head1 METHODS
  84
  85 Functionality available if using the object interface..
  86
  87 =cut
  88
  89 =head2 decode($encoded_string,[optional CLASS])
  90
  91 Deserializes the encoded data in $encoded, and returns a value (be it a hashref, arrayref, scalar, etc)
  92 representing the data structure serialized in $encoded_string.
  93
  94 If the optional CLASS is specified, any objects are blessed into CLASS::$serialized_class. Otherwise,
  95 Objects are blessed into PHP::Serialization::Object::$serialized_class. (which has no methods)
  96
  97 SEE ALSO: unserialize()
  98
  99 =cut
 100
 101 my $sorthash;
 102
 103 sub decode {
 104     my ($self, $string, $class, $shash) = @_;
 105     $sorthash=$shash if defined($shash);
 106
 107     my $cursor = 0;
 108     $self->{string} = \$string;
 109     $self->{cursor} = \$cursor;
 110     $self->{strlen} = length($string);
 111
 112     if ( defined $class ) {
 113         $self->{class} = $class;
 114     }
 115     else {
 116         $self->{class} = 'PHP::Serialization::Object';
 117     }
 118
 119     # Ok, start parsing...
 120     my @values = $self->_parse();
 121
 122     # Ok, we SHOULD only have one value..
 123     if ( $#values == -1 ) {
 124         # Oops, none...
 125         return;
 126     }
 127     elsif ( $#values == 0 ) {
 128         # Ok, return our one value..
 129         return $values[0];
 130     }
 131     else {
 132         # Ok, return a reference to the list.
 133         return \@values;
 134     }
 135
 136 } # End of decode sub.
 137
 138 my %type_table = (
 139     O => 'object',
 140     s => 'scalar',
 141     a => 'array',
 142     i => 'integer',
 143     d => 'float',
 144     b => 'boolean',
 145     N => 'undef',
 146 );
 147
 148 sub _parse_array {
 149     my $self = shift;
 150     my $elemcount = shift;
 151     my $cursor = $self->{cursor};
 152     my $string = $self->{string};
 153     my $strlen = $self->{strlen};
 154     confess("No cursor") unless $cursor;
 155     confess("No string") unless $string;
 156     confess("No strlen") unless $strlen;
 157
 158     my @elems = ();
 159     my @shash_arr = ('some') if (($sorthash) and (ref($sorthash) eq 'HASH'));
 160
 161     $self->_skipchar('{');
 162     foreach my $i (1..$elemcount*2) {
 163         push(@elems,$self->_parse_elem);
 164         if (($i % 2) and (@shash_arr)) {
 165             $shash_arr[0]= ((($i-1)/2) eq $elems[$#elems])? 'array' : 'hash' unless ($shash_arr[0] eq 'hash');
 166             push(@shash_arr,$elems[$#elems]);
 167         }
 168     }
 169     $self->_skipchar('}');
 170     push(@elems,\@shash_arr) if (@shash_arr);
 171     return @elems;
 172 }
 173
 174 sub _parse_elem {
 175     my $self = shift;
 176     my $cursor = $self->{cursor};
 177     my $string = $self->{string};
 178     my $strlen = $self->{strlen};
 179
 180     my @elems;
 181
 182     my $type_c = $self->_readchar();
 183     my $type = $type_table{$type_c};
 184     if (!defined $type) {
 185         croak("ERROR: Unknown type $type_c.");
 186     }
 187
 188     if ( $type eq 'object' ) {
 189         $self->_skipchar(':');
 190         # Ok, get our name count...
 191         my $namelen = $self->_readnum();
 192         $self->_skipchar(':');
 193
 194         # Ok, get our object name...
 195         $self->_skipchar('"');
 196         my $name = $self->_readstr($namelen);
 197         $self->_skipchar('"');
 198
 199         # Ok, our sub elements...
 200         $self->_skipchar(':');
 201         my $elemcount = $self->_readnum();
 202         $self->_skipchar(':');
 203
 204         my %value = $self->_parse_array($elemcount);
 205
 206         # TODO: Call wakeup
 207         # TODO: Support for objecttypes
 208         return bless(\%value, $self->{class} . '::' . $name);
 209     } elsif ( $type eq 'array' ) {
 210         $self->_skipchar(':');
 211         # Ok, our sub elements...
 212         my $elemcount = $self->_readnum();
 213         $self->_skipchar(':');
 214
 215         my @values = $self->_parse_array($elemcount);
 216         # If every other key is not numeric, map to a hash..
 217         my $subtype = 'array';
 218         my @newlist;
 219         my @shash_arr=@{pop(@values)} if (ref($sorthash) eq 'HASH');
 220         foreach ( 0..$#values ) {
 221             if ( ($_ % 2) ) {
 222                 push(@newlist, $values[$_]);
 223                 next;
 224             } elsif (($_ / 2) ne $values[$_]) {
 225                 $subtype = 'hash';
 226                 last;
 227             }
 228             if ( $values[$_] !~ /^\d+$/ ) {
 229                 $subtype = 'hash';
 230                 last;
 231             }
 232         }
 233         if ( $subtype eq 'array' ) {
 234             # Ok, remap...
 235             return \@newlist;
 236         } else {
 237             # Ok, force into hash..
 238             my %hash = @values;
 239             ${$sorthash}{\%hash}=@shash_arr if ((ref($sorthash) eq 'HASH') and @shash_arr and (shift(@shash_arr) ne 'array'));
 240             return \%hash;
 241         }
 242     }
 243     elsif ( $type eq 'scalar' ) {
 244         $self->_skipchar(':');
 245         # Ok, get our string size count...
 246         my $strlen = $self->_readnum;
 247         $self->_skipchar(':');
 248
 249         $self->_skipchar('"');
 250         my $string = $self->_readstr($strlen);
 251         $self->_skipchar('"');
 252         $self->_skipchar(';');
 253         return $string;
 254     }
 255     elsif ( $type eq 'integer' || $type eq 'float' ) {
 256         $self->_skipchar(':');
 257         # Ok, read the value..
 258         my $val = $self->_readnum;
 259         if ( $type eq 'integer' ) { $val = int($val); }
 260         $self->_skipchar(';');
 261         return $val;
 262     }
 263     elsif ( $type eq 'boolean' ) {
 264         $self->_skipchar(':');
 265         # Ok, read our boolen value..
 266         my $bool = $self->_readchar;
 267
 268         $self->_skipchar;
 269         if ($bool eq '0') {
 270             $bool = undef;
 271         }
 272         return $bool;
 273     }
 274     elsif ( $type eq 'undef' ) {
 275         $self->_skipchar(';');
 276         return undef;
 277     }
 278     else {
 279         confess "Unknown element type '$type' found! (cursor $$cursor)";
 280     }
 281
 282 }
 283
 284
 285 sub _parse {
 286     my ($self) = @_;
 287     my $cursor = $self->{cursor};
 288     my $string = $self->{string};
 289     my $strlen = $self->{strlen};
 290     confess("No cursor") unless $cursor;
 291     confess("No string") unless $string;
 292     confess("No strlen") unless $strlen;
 293     my @elems;
 294     push(@elems,$self->_parse_elem);
 295
 296     # warn if we have unused chars
 297     if ($$cursor != $strlen) {
 298         carp("WARN: Unused characters in string after $$cursor.");
 299     }
 300     return @elems;
 301
 302 } # End of decode.
 303
 304 sub _readstr {
 305     my ($self, $length) = @_;
 306     my $string = $self->{string};
 307     my $cursor = $self->{cursor};
 308     if ($$cursor + $length > length($$string)) {
 309         croak("ERROR: Read past end of string. Want $length after $$cursor. (".$$string.")");
 310     }
 311     my $str = substr($$string, $$cursor, $length);
 312     $$cursor += $length;
 313
 314     return $str;
 315 }
 316
 317 sub _readchar {
 318     my ($self) = @_;
 319     return $self->_readstr(1);
 320 }
 321
 322 sub _readnum {
 323     # Reads in a character at a time until we run out of numbers to read...
 324     my ($self) = @_;
 325     my $cursor = $self->{cursor};
 326
 327     my $string;
 328     while ( 1 ) {
 329         my $char = $self->_readchar;
 330         if ( $char !~ /^[\d\.-]+$/ ) {
 331             $$cursor--;
 332             last;
 333         }
 334         $string .= $char;
 335     } # End of while.
 336
 337     return $string;
 338 } # End of readnum
 339
 340 sub _skipchar {
 341     my $self = shift;
 342     my $want = shift;
 343     my $c = $self->_readchar();
 344     if (($want)&&($c ne $want)) {
 345         my $cursor = $self->{cursor};
 346         my $str = $self->{string};
 347         croak("ERROR: Wrong char $c, expected $want at position ".$$cursor." (".$$str.")");
 348     }
 349     print "_skipchar: WRONG char $c ($want)\n" if (($want)&&($c ne $want));
 350     # ${$$self{cursor}}++;
 351 } # Move our cursor one bytes ahead...
 352
 353
 354 =head2 encode($reference,[optional $asString,[optional $sortHashes]])
 355
 356 Serializes the memory structure pointed to by $reference, and returns a scalar value of encoded data.
 357
 358 If the optional $asString is true, $reference will be encoded as string if it is double or float.
 359
 360 If the optional $sortHashes is true, all hashes will be sorted before serialization.
 361
 362 NOTE: Will recursively encode objects, hashes, arrays, etc.
 363
 364 SEE ALSO: serialize()
 365
 366 =cut
 367
 368 sub encode {
 369     my ($self, $val, $iskey, $shash) = @_;
 370     $iskey=0 unless defined $iskey;
 371     $sorthash=$shash if defined $shash;
 372
 373     if ( ! defined $val ) {
 374         return $self->_encode('null', $val);
 375     }
 376     elsif ( blessed $val ) {
 377         return $self->_encode('obj', $val);
 378     }
 379     elsif ( ! ref($val) ) {
 380         if ( $val =~ /^-?(?:[0-9]|[1-9]\d{1,10})$/ && abs($val) < 2**31 ) {
 381             return $self->_encode('int', $val);
 382         }
 383         elsif ( $val =~ /^-?\d+\.\d*$/ && !$iskey) {
 384             return $self->_encode('float', $val);
 385         }
 386         else {
 387             return $self->_encode('string', $val);
 388         }
 389     }
 390     else {
 391         my $type = ref($val);
 392         if ($type eq 'HASH' || $type eq 'ARRAY' ) {
 393             return $self->_sort_hash_encode($val) if (($sorthash) and ($type eq 'HASH'));
 394             return $self->_encode('array', $val);
 395         }
 396         else {
 397             confess "I can't serialize data of type '$type'!";
 398         }
 399     }
 400 }
 401
 402 sub _sort_hash_encode {
 403     my ($self, $val) = @_;
 404
 405     my $buffer = '';
 406     my @hsort = ((ref($sorthash) eq 'HASH') and (ref(${$sorthash}{$val}) eq 'ARRAY')) ? ${$sorthash}{$val} : sort keys %{$val};
 407     $buffer .= sprintf('a:%d:',scalar(@hsort)) . '{';
 408     for (@hsort) {
 409         $buffer .= $self->encode($_,1);
 410         $buffer .= $self->encode($$val{$_});
 411     }
 412     $buffer .= '}';
 413     return $buffer;
 414 }
 415
 416 sub _encode {
 417     my ($self, $type, $val) = @_;
 418
 419     my $buffer = '';
 420     if ( $type eq 'null' ) {
 421         $buffer .= 'N;';
 422     }
 423     elsif ( $type eq 'int' ) {
 424         $buffer .= sprintf('i:%d;', $val);
 425     }
 426     elsif ( $type eq 'float' ) {
 427         $buffer .= sprintf('d:%s;', $val);
 428     }
 429     elsif ( $type eq 'string' ) {
 430         $buffer .= sprintf('s:%d:"%s";', length($val), $val);
 431     }
 432     elsif ( $type eq 'array' ) {
 433         if ( ref($val) eq 'ARRAY' ) {
 434             $buffer .= sprintf('a:%d:',($#{$val}+1)) . '{';
 435             map { # Ewww
 436                 $buffer .= $self->encode($_);
 437                 $buffer .= $self->encode($$val[$_]);
 438             } 0..$#{$val};
 439             $buffer .= '}';
 440         }
 441         else {
 442             $buffer .= sprintf('a:%d:',scalar(keys(%{$val}))) . '{';
 443              while ( my ($key, $value) = each(%{$val}) ) {
 444                  $buffer .= $self->encode($key,1);
 445                  $buffer .= $self->encode($value);
 446             }
 447             $buffer .= '}';
 448         }
 449     }
 450     elsif ( $type eq 'obj' ) {
 451         my $class = ref($val);
 452         $class =~ /(\w+)$/;
 453         my $subclass = $1;
 454         $buffer .= sprintf('O:%d:"%s":%d:', length($subclass), $subclass, scalar(keys %{$val})) . '{';
 455         foreach ( %{$val} ) {
 456             $buffer .= $self->encode($_);
 457         }
 458         $buffer .= '}';
 459     }
 460     else {
 461         confess "Unknown encode type!";
 462     }
 463     return $buffer;
 464
 465 }
 466
 467 =head1 TODO
 468
 469 Support diffrent object types
 470
 471 =head1 AUTHOR INFORMATION
 472
 473 Copyright (c) 2003 Jesse Brown <jbrown@cpan.org>. All rights reserved. This program is free software;
 474 you can redistribute it and/or modify it under the same terms as Perl itself.
 475
 476 Various patches contributed by assorted authors on rt.cpan.org (as detailed in Changes file).
 477
 478 Currently maintained by Tomas Doran <bobtfish@bobtfish.net>.
 479
 480 Rewritten to solve all known bugs by Bjørn-Olav Strand <bolav@cpan.org>
 481
 482 =cut
 483
 484 package PHP::Serialization::Object;
 485
 486 1;