/usr/share/perl5/CGI/Session/Serialize/default.pm is in libcgi-session-perl 4.48-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | package CGI::Session::Serialize::default;
# $Id$
use strict;
use Safe;
use Data::Dumper;
use CGI::Session::ErrorHandler;
use Scalar::Util qw(blessed reftype refaddr);
use Carp "croak";
use vars qw( %overloaded );
require overload;
@CGI::Session::Serialize::default::ISA = ( "CGI::Session::ErrorHandler" );
$CGI::Session::Serialize::default::VERSION = '4.43';
sub freeze {
my ($class, $data) = @_;
my $d =
new Data::Dumper([$data], ["D"]);
$d->Indent( 0 );
$d->Purity( 1 );
$d->Useqq( 0 );
$d->Deepcopy( 0 );
$d->Quotekeys( 1 );
$d->Terse( 0 );
# ;$D added to make certain we get our data structure back when we thaw
return $d->Dump() . ';$D';
}
sub thaw {
my ($class, $string) = @_;
# To make -T happy
my ($safe_string) = $string =~ m/^(.*)$/s;
my $rv = Safe->new->reval( $safe_string );
if ( $@ ) {
return $class->set_error("thaw(): couldn't thaw. $@");
}
__walk($rv);
return $rv;
}
sub __walk {
my %seen;
my @filter = __scan(shift);
local %overloaded;
# We allow the value assigned to a key to be undef.
# Hence the defined() test is not in the while().
while (@filter) {
defined(my $x = shift @filter) or next;
$seen{refaddr $x || ''}++ and next;
my $r = reftype $x or next;
if ($r eq "HASH") {
# we use this form to make certain we have aliases
# to the values in %$x and not copies
push @filter, __scan(@{$x}{keys %$x});
} elsif ($r eq "ARRAY") {
push @filter, __scan(@$x);
} elsif ($r eq "SCALAR" || $r eq "REF") {
push @filter, __scan($$x);
}
}
}
# we need to do this because the values we get back from the safe compartment
# will have packages defined from the safe compartment's *main instead of
# the one we use
sub __scan {
# $_ gets aliased to each value from @_ which are aliases of the values in
# the current data structure
for (@_) {
if (blessed $_) {
if (overload::Overloaded($_)) {
my $address = refaddr $_;
# if we already rebuilt and reblessed this item, use the cached
# copy so our ds is consistent with the one we serialized
if (exists $overloaded{$address}) {
$_ = $overloaded{$address};
} else {
my $reftype = reftype $_;
if ($reftype eq "HASH") {
$_ = $overloaded{$address} = bless { %$_ }, ref $_;
} elsif ($reftype eq "ARRAY") {
$_ = $overloaded{$address} = bless [ @$_ ], ref $_;
} elsif ($reftype eq "SCALAR" || $reftype eq "REF") {
$_ = $overloaded{$address} = bless \do{my $o = $$_},ref $_;
} else {
croak "Do not know how to reconstitute blessed object of base type $reftype";
}
}
} else {
bless $_, ref $_;
}
}
}
return @_;
}
1;
__END__;
=pod
=head1 NAME
CGI::Session::Serialize::default - Default CGI::Session serializer
=head1 DESCRIPTION
This library is used by CGI::Session driver to serialize session data before storing it in disk.
All the methods are called as class methods.
=head1 METHODS
=over 4
=item freeze($class, \%hash)
Receives two arguments. First is the class name, the second is the data to be serialized. Should return serialized string on success, undef on failure. Error message should be set using C<set_error()|CGI::Session::ErrorHandler/"set_error()">
=item thaw($class, $string)
Received two arguments. First is the class name, second is the I<frozen> data string. Should return thawed data structure on success, undef on failure. Error message should be set using C<set_error()|CGI::Session::ErrorHandler/"set_error()">
=back
=head1 LICENSING
For support and licensing see L<CGI::Session|CGI::Session>
=cut
|