home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Serialization.pm < prev    next >
Encoding:
Perl POD Document  |  2004-02-23  |  9.4 KB  |  387 lines
  1. package PHP::Serialization;
  2. use strict;
  3. use warnings;
  4.  
  5. BEGIN {
  6.     use Exporter ();
  7.     our ($VERSION,@EXPORT_OK,@ISA);
  8.  
  9.     # Revision.
  10.     $VERSION = 0.27;
  11.     
  12.     # Our inheritence
  13.     @ISA = qw(Exporter);
  14.  
  15.     # Stuff they can request.
  16.     @EXPORT_OK = qw(unserialize serialize);
  17. }
  18. our (@EXPORT_OK);
  19.  
  20. =head1 NAME
  21.  
  22. PHP::Serialization - simple flexible means of converting the output of PHP's serialize() into the equivalent Perl memory structure, and vice versa.
  23.  
  24. =head1 SYNOPSIS
  25.  
  26.     use PHP::Serialization qw(serialize unserialize);
  27.     my $encoded = serialize({ a => 1, b => 2});
  28.     my $hashref = unserialize($encoded);
  29.  
  30. =cut
  31.  
  32.  
  33. =head1 DESCRIPTION
  34.  
  35.     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. 
  36.  
  37.     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.
  38.  
  39. =cut
  40.  
  41. sub new {
  42.     my $self = bless({},shift);
  43.     return $self;
  44. }
  45.  
  46. =head1 FUNCTIONS
  47.  
  48. Exportable functions..
  49.  
  50. =cut
  51.  
  52. =head2 serialize($var)
  53.  
  54.     Serializes the memory structure pointed to by $var, and returns a scalar value of encoded data. 
  55.  
  56.     NOTE: Will recursively encode objects, hashes, arrays, etc. 
  57.  
  58.     SEE ALSO: ->encode()
  59.  
  60. =cut
  61.  
  62. sub serialize {
  63.     my $obj = PHP::Serialization->new();
  64.     return $obj->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) representing the data structure serialized in $encoded_string.
  70.  
  71.   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)
  72.  
  73.     SEE ALSO: ->decode()
  74.  
  75. =cut
  76.  
  77. sub unserialize {
  78.     my $obj = PHP::Serialization->new();
  79.     return $obj->decode(@_);
  80. } # End of sub.
  81.  
  82. =head1 METHODS
  83.  
  84. Functionality available if using the object interface..
  85.  
  86. =cut
  87.  
  88. =head2 decode($encoded_string,[optional CLASS])
  89.  
  90.   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.
  91.  
  92.   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)
  93.  
  94.     SEE ALSO: unserialize()
  95.  
  96. =cut
  97.  
  98. sub decode {
  99.     my $self = shift;
  100.     my $string = shift;
  101.     my $class = shift;
  102.  
  103.     use Carp qw(croak confess);
  104.     my $cursor = 0;
  105.     $$self{'string'} = \$string;
  106.     $$self{'cursor'} = \$cursor;
  107.     $$self{'strlen'} = length($string);
  108.  
  109.     if ( defined $class ) {
  110.         $$self{'class'} = $class;
  111.     } else {
  112.         $$self{'class'} = 'PHP::Serialization::Object';
  113.     }    
  114.  
  115.     # Ok, start parsing...
  116.     my @values = $self->_parse();
  117.  
  118.     # Ok, we SHOULD only have one value.. 
  119.     if ( $#values == -1 ) {
  120.         # Oops, none...
  121.         return;
  122.     } elsif ( $#values == 0 ) {
  123.         # Ok, return our one value..
  124.         return $values[0];
  125.     } else {
  126.         # Ok, return a reference to the list.
  127.         return \@values;
  128.     }
  129.  
  130. } # End of decode sub.
  131.  
  132. my %type_table = (
  133.     'O' => 'object',
  134.     's' => 'scalar',
  135.     'a' => 'array',
  136.     'i' => 'integer',
  137.     'd'    => 'float',
  138.     'b' => 'boolean',
  139.     'N' => 'undef',
  140. );
  141.  
  142.  
  143. sub _parse {
  144.     my $self = shift;
  145.     my $cursor = $$self{'cursor'};
  146.     my $string = $$self{'string'};
  147.     my $strlen = $$self{'strlen'};
  148.     
  149.     use Carp qw(croak confess);
  150.  
  151.     my @elems;    
  152.     while ( $$cursor < $strlen ) {
  153.         # Ok, decode the type...
  154.         my $type = $self->_readchar();
  155.         # Ok, see if 'type' is a start/end brace...
  156.         if ( $type eq '{' ) { next; };
  157.         if ( $type eq '}' ) { 
  158.             last; 
  159.         };
  160.  
  161.         if ( ! exists $type_table{$type} ) {
  162.             confess "Unknown type '$type'! at $$cursor";
  163.         }
  164.         $self->_skipchar(); # Toss the seperator
  165.         $type = $type_table{$type};
  166.     
  167.         # Ok, do per type processing..
  168.         if ( $type eq 'object' ) {
  169.             # Ok, get our name count...
  170.             my $namelen = $self->_readnum();
  171.             $self->_skipchar(); # Toss the seperator
  172.  
  173.             # Ok, get our object name...
  174.             $self->_skipchar(); # Toss the seperator
  175.             my $name = $self->_readstr($namelen);
  176.             $self->_skipchar(); # Toss the seperator
  177.  
  178.             # Ok, our sub elements...
  179.             $self->_skipchar(); # Toss the seperator
  180.             my $elemcount = $self->_readnum();
  181.             $self->_skipchar(); # Toss the seperator
  182.  
  183.             my %value = $self->_parse();
  184.             push(@elems,bless(\%value,$$self{'class'} . '::' . $name));
  185.         } elsif ( $type eq 'array' ) {
  186.             # Ok, our sub elements...
  187.             $self->_skipchar(); # Toss the seperator
  188.             my $elemcount = $self->_readnum();
  189.             $self->_skipchar(); # Toss the seperator
  190.  
  191.             my @values = $self->_parse();
  192.             # If every other key is not numeric, map to a hash..
  193.             my $subtype = 'array';
  194.             my @newlist;
  195.             foreach ( 0..$#values ) {
  196.                 if ( ($_ % 2) ) { 
  197.                     push(@newlist,$values[$_]);
  198.                     next; 
  199.                 }
  200.                 if ( $values[$_] !~ /^\d+$/ ) {
  201.                     $subtype = 'hash';
  202.                     last;
  203.                 }
  204.             }
  205.             if ( $subtype eq 'array' ) {
  206.                 # Ok, remap...
  207.                 push(@elems,\@newlist);
  208.             } else {
  209.                 # Ok, force into hash..
  210.                 my %hash = @values;
  211.                 push(@elems,\%hash);
  212.             }
  213.         } elsif ( $type eq 'scalar' ) {
  214.             # Ok, get our string size count...
  215.             my $strlen = $self->_readnum();
  216.             $self->_skipchar(); # Toss the seperator
  217.  
  218.             $self->_skipchar(); # Toss the seperator
  219.             my $string = $self->_readstr($strlen);
  220.             $self->_skipchar(); # Toss the seperator
  221.             $self->_skipchar(); # Toss the seperator
  222.         
  223.             push(@elems,$string);    
  224.         } elsif ( $type eq 'integer' || $type eq 'float' ) {
  225.             # Ok, read the value..
  226.             my $val = $self->_readnum();
  227.             if ( $type eq 'integer' ) { $val = int($val); }
  228.             $self->_skipchar(); # Toss the seperator
  229.             push(@elems,$val);
  230.         } elsif ( $type eq 'boolean' ) {
  231.             # Ok, read our boolen value..
  232.             my $bool = $self->_readchar();
  233.             $self->_skipchar(); # Toss the seperator
  234.             push(@elems,$bool);
  235.         } elsif ( $type eq 'undef' ) {
  236.             # Ok, undef value..
  237.             push(@elems,undef);
  238.         } else {
  239.             confess "Unknown element type '$type' found! (cursor $$cursor)";
  240.         }
  241.     } # End of while.
  242.  
  243.     # Ok, return our elements list...
  244.     return @elems;
  245.     
  246. } # End of decode.
  247.  
  248. sub _readstr {
  249.     my $self = shift;
  250.     my $string = $$self{'string'};
  251.     my $cursor = $$self{'cursor'};
  252.     my $length = shift;
  253.  
  254.     my $str = substr($$string,$$cursor,$length);
  255.     $$cursor += $length;
  256.  
  257.     return $str;
  258. } # End of readstr.
  259.  
  260. sub _readchar {
  261.     my $self = shift;
  262.     return $self->_readstr(1);
  263. } # End of readstr.
  264.  
  265. sub _readnum {
  266.     # Reads in a character at a time until we run out of numbers to read...
  267.     my $self = shift;
  268.     my $cursor = $$self{'cursor'};
  269.  
  270.     my $string;
  271.     while ( 1 ) {
  272.         my $char = $self->_readchar();
  273.         if ( $char !~ /^[\d\.]+$/ ) {
  274.             $$cursor--;
  275.             last;
  276.         }
  277.         $string .= $char;
  278.     } # End of while.
  279.  
  280.     return $string;
  281. } # End of readnum
  282.  
  283. sub _skipchar {
  284.     my $self = shift;
  285.     ${$$self{'cursor'}}++;
  286. } # Move our cursor one bytes ahead...
  287.  
  288.  
  289. =head2 encode($reference)
  290.  
  291.     Serializes the memory structure pointed to by $var, and returns a scalar value of encoded data. 
  292.  
  293.     NOTE: Will recursively encode objects, hashes, arrays, etc. 
  294.  
  295.     SEE ALSO: serialize()
  296.  
  297. =cut
  298.  
  299. sub encode {
  300.     my $self = shift;
  301.     my $val = shift;
  302.  
  303.     use Carp qw(confess);
  304.     if ( ! defined $val ) {
  305.         return $self->_encode('null',$val);
  306.     } elsif ( ! ref($val) ) {
  307.         if ( $val =~ /^-?\d+$/ ) {
  308.             return $self->_encode('int',$val);
  309.         } elsif ( $val =~ /^-?\d+(\.\d+)?$/ ) {
  310.             return $self->_encode('float',$val);
  311.         } else {
  312.             return $self->_encode('string',$val);
  313.         }
  314.     } else {
  315.         my $type = ref($val);
  316.         if ( $type eq 'HASH' || $type eq 'ARRAY' ) {
  317.             return $self->_encode('array',$val);
  318.         } elsif ( $type eq 'CODE' || $type eq 'REF' || $type eq 'GLOB' || $type eq 'LVALUE' ) {
  319.             confess "I can't serialize data of type '$type'!";
  320.         } else {
  321.             # Object...
  322.             return $self->_encode('obj',$val);
  323.         }
  324.     }
  325. } # End of encode
  326.  
  327. sub _encode {
  328.     my $self = shift;
  329.     my $type = shift;
  330.     my $val = shift;
  331.  
  332.     my $buffer = '';
  333.     if ( $type eq 'null' ) {
  334.         $buffer .= 'N;';
  335.     } elsif ( $type eq 'int' ) {
  336.         $buffer .= sprintf('i:%d;',$val);
  337.     } elsif ( $type eq 'float' ) {
  338.         $buffer .= sprintf('d:%s;',$val);
  339.     } elsif ( $type eq 'string' ) {
  340.         $buffer .= sprintf('s:%d:"%s";',length($val),$val);
  341.     } elsif ( $type eq 'array' ) {
  342.         if ( ref($val) eq 'ARRAY' ) {
  343.             $buffer .= sprintf('a:%d:',($#{$val}+1)) . '{';
  344.             map { $buffer .= $self->encode($_); $buffer .= $self->encode($$val[$_]); } 0..$#{$val};
  345.             $buffer .= '}';
  346.         } else {
  347.             $buffer .= sprintf('a:%d:',scalar(keys(%{$val}))) . '{';
  348.             foreach ( %{$val} ) { $buffer .= $self->encode($_); }
  349.             $buffer .= '}';    
  350.         }
  351.     } elsif ( $type eq 'obj' ) {
  352.         my $class = ref($val);
  353.         $class =~ /(\w+)$/;
  354.         my $subclass = $1;
  355.         $buffer .= sprintf('O:%d:"%s":%d:',length($subclass),$subclass,scalar(keys(%{$val}))) . '{';
  356.         foreach ( %{$val} ) { $buffer .= $self->encode($_); }
  357.         $buffer .= '}';
  358.     } else {
  359.         use Carp qw(confess);
  360.         confess "Unknown encode type!";
  361.     }    
  362.     return $buffer;    
  363.  
  364. } # End of _encode sub.
  365.  
  366. =head1 BUGS
  367.  
  368.     None known yet, feel free to report some!
  369.  
  370. =cut
  371.  
  372. =head1 TODO
  373.  
  374.     Make faster! (and more efficent?)
  375.  
  376. =cut
  377.  
  378. =head1 AUTHOR INFORMATION
  379.  
  380.  Copyright (c) 2003 Jesse Brown <jbrown@cpan.org>. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
  381.  
  382. =cut
  383.  
  384. package PHP::Serialization::Object;
  385.  
  386. 1;
  387.