r39981 - in /trunk/libphp-serialization-perl: Changes MANIFEST META.yml README debian/changelog lib/PHP/Serialization.pm sort_hashes.patch
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Wed Jul 15 22:08:52 UTC 2009
Author: jawnsy-guest
Date: Wed Jul 15 22:08:47 2009
New Revision: 39981
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=39981
Log:
* New upstream release
+ New features: store key ordering, sort hashes before encoding
Added:
trunk/libphp-serialization-perl/sort_hashes.patch
Modified:
trunk/libphp-serialization-perl/Changes
trunk/libphp-serialization-perl/MANIFEST
trunk/libphp-serialization-perl/META.yml
trunk/libphp-serialization-perl/README
trunk/libphp-serialization-perl/debian/changelog
trunk/libphp-serialization-perl/lib/PHP/Serialization.pm
Modified: trunk/libphp-serialization-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libphp-serialization-perl/Changes?rev=39981&op=diff
==============================================================================
--- trunk/libphp-serialization-perl/Changes (original)
+++ trunk/libphp-serialization-perl/Changes Wed Jul 15 22:08:47 2009
@@ -1,4 +1,10 @@
Revision history for Perl extension PHP::Serialization
+
+0.33 2009-07-14
+ - Added ability to store the order of the keys on decoding
+ PHP assoc array (Alexander Bassilov)
+ - Added ability to sort the keys on encoding HASHes (Alexander
+ Bassilov)
0.32 2009-06-20
- Making finite state machine
Modified: trunk/libphp-serialization-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libphp-serialization-perl/MANIFEST?rev=39981&op=diff
==============================================================================
--- trunk/libphp-serialization-perl/MANIFEST (original)
+++ trunk/libphp-serialization-perl/MANIFEST Wed Jul 15 22:08:47 2009
@@ -3,6 +3,7 @@
Makefile.PL
MANIFEST This list of files
README
+sort_hashes.patch
t/01use.t
t/02basic.t
t/03largeints.t
Modified: trunk/libphp-serialization-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libphp-serialization-perl/META.yml?rev=39981&op=diff
==============================================================================
--- trunk/libphp-serialization-perl/META.yml (original)
+++ trunk/libphp-serialization-perl/META.yml Wed Jul 15 22:08:47 2009
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: PHP-Serialization
-version: 0.32
+version: 0.33
abstract: simple flexible means of converting the output of PHP's serialize() into the equivalent Perl memory structure, and vice versa.
author:
- Jesse Brown <jbrown at cpan.org>
Modified: trunk/libphp-serialization-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libphp-serialization-perl/README?rev=39981&op=diff
==============================================================================
--- trunk/libphp-serialization-perl/README (original)
+++ trunk/libphp-serialization-perl/README Wed Jul 15 22:08:47 2009
@@ -4,9 +4,9 @@
versa.
SYNOPSIS
- use PHP::Serialization qw(serialize unserialize);
- my $encoded = serialize({ a => 1, b => 2});
- my $hashref = unserialize($encoded);
+ use PHP::Serialization qw(serialize unserialize);
+ my $encoded = serialize({ a => 1, b => 2});
+ my $hashref = unserialize($encoded);
DESCRIPTION
Provides a simple, quick means of serializing perl memory structures
@@ -20,9 +20,15 @@
FUNCTIONS
Exportable functions..
- serialize($var)
+ 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.
@@ -53,21 +59,32 @@
SEE ALSO: unserialize()
- encode($reference)
- Serializes the memory structure pointed to by $var, and returns a scalar
- value of encoded data.
+ 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()
TODO
- Make faster! (and more efficent?)
+ Support diffrent object types
AUTHOR INFORMATION
Copyright (c) 2003 Jesse Brown <jbrown at 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.
+ Various patches contributed by assorted authors on rt.cpan.org (as
+ detailed in Changes file).
+
Currently maintained by Tomas Doran <bobtfish at bobtfish.net>.
+ Rewritten to solve all known bugs by Bjørn-Olav Strand <bolav at cpan.org>
+
Modified: trunk/libphp-serialization-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libphp-serialization-perl/debian/changelog?rev=39981&op=diff
==============================================================================
--- trunk/libphp-serialization-perl/debian/changelog (original)
+++ trunk/libphp-serialization-perl/debian/changelog Wed Jul 15 22:08:47 2009
@@ -1,3 +1,10 @@
+libphp-serialization-perl (0.33-1) UNRELEASED; urgency=low
+
+ * New upstream release
+ + New features: store key ordering, sort hashes before encoding
+
+ -- Jonathan Yu <frequency at cpan.org> Wed, 15 Jul 2009 14:07:49 -0400
+
libphp-serialization-perl (0.32-1) unstable; urgency=low
[ Nathan Handler ]
Modified: trunk/libphp-serialization-perl/lib/PHP/Serialization.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libphp-serialization-perl/lib/PHP/Serialization.pm?rev=39981&op=diff
==============================================================================
--- trunk/libphp-serialization-perl/lib/PHP/Serialization.pm (original)
+++ trunk/libphp-serialization-perl/lib/PHP/Serialization.pm Wed Jul 15 22:08:47 2009
@@ -8,9 +8,9 @@
use vars qw/$VERSION @ISA @EXPORT_OK/;
-$VERSION = '0.32';
-
- at ISA = qw(Exporter);
+$VERSION = '0.33';
+
+ at ISA = qw(Exporter);
@EXPORT_OK = qw(unserialize serialize);
=head1 NAME
@@ -19,16 +19,16 @@
=head1 SYNOPSIS
- use PHP::Serialization qw(serialize unserialize);
- my $encoded = serialize({ a => 1, b => 2});
- my $hashref = unserialize($encoded);
+ 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.
+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.
@@ -36,8 +36,8 @@
sub new {
my ($class) = shift;
- my $self = bless {}, blessed($class) ? blessed($class) : $class;
- return $self;
+ my $self = bless {}, blessed($class) ? blessed($class) : $class;
+ return $self;
}
=head1 FUNCTIONS
@@ -46,23 +46,27 @@
=cut
-=head2 serialize($var)
-
-Serializes the memory structure pointed to by $var, and returns a scalar value of encoded data.
-
-NOTE: Will recursively encode objects, hashes, arrays, etc.
+=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(@_);
+ 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)
+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
@@ -73,7 +77,7 @@
=cut
sub unserialize {
- return __PACKAGE__->new->decode(@_);
+ return __PACKAGE__->new->decode(@_);
}
=head1 METHODS
@@ -84,348 +88,379 @@
=head2 decode($encoded_string,[optional CLASS])
-Deserializes the encoded data in $encoded, and returns a value (be it a hashref, arrayref, scalar, etc)
+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,
+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) = @_;
-
- 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;
+ 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]);
}
-
-} # 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 = ();
-
- $self->_skipchar('{');
- foreach my $i (1..$elemcount*2) {
- push(@elems,$self->_parse_elem);
- }
- $self->_skipchar('}');
- return @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;
- 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;
- 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;
+ 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)";
- }
-
+ 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;
-
+ 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;
+ 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);
+ 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;
+ # 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 $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}}++;
+ 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)
-
-Serializes the memory structure pointed to by $var, and returns a scalar value of encoded data.
-
-NOTE: Will recursively encode objects, hashes, arrays, etc.
+=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) = @_;
- $iskey=0 unless defined $iskey;
-
- if ( ! defined $val ) {
- return $self->_encode('null', $val);
- }
- elsif ( blessed $val ) {
- return $self->_encode('obj', $val);
- }
- elsif ( ! ref($val) ) {
- if ( $val =~ /^-?\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->_encode('array', $val);
- }
- else {
- confess "I can't serialize data of type '$type'!";
- }
- }
+ 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 =~ /^-?\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;
+ 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;
}
@@ -435,7 +470,7 @@
=head1 AUTHOR INFORMATION
-Copyright (c) 2003 Jesse Brown <jbrown at cpan.org>. All rights reserved. This program is free software;
+Copyright (c) 2003 Jesse Brown <jbrown at 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.
Various patches contributed by assorted authors on rt.cpan.org (as detailed in Changes file).
Added: trunk/libphp-serialization-perl/sort_hashes.patch
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libphp-serialization-perl/sort_hashes.patch?rev=39981&op=file
==============================================================================
--- trunk/libphp-serialization-perl/sort_hashes.patch (added)
+++ trunk/libphp-serialization-perl/sort_hashes.patch Wed Jul 15 22:08:47 2009
@@ -1,0 +1,26 @@
+348a349,350
+> my $sorthash;
+>
+350c352
+< my ($self, $val, $iskey) = @_;
+---
+> my ($self, $val, $iskey, $shash) = @_;
+351a354
+> $sorthash=$shash if defined $shash;
+372a376
+> return $self->_sort_hash_encode($val) if (($type eq 'HASH') and ($sorthash));
+380a385,398
+> sub _sort_hash_encode {
+> my ($self, $val) = @_;
+>
+> my $buffer = '';
+> my @hsort = sort keys %{$val};
+> $buffer .= sprintf('a:%d:',scalar(@hsort)) . '{';
+> for (@hsort) {
+> $buffer .= $self->encode($_,1);
+> $buffer .= $self->encode($$val{$_});
+> }
+> $buffer .= '}';
+> return $buffer;
+> }
+>
More information about the Pkg-perl-cvs-commits
mailing list