File Coverage

blib/lib/CGI/Session/Serialize/default.pm

Criterion	Covered	Total	%
statement	58	64	90.6
branch	17	26	65.3
condition	2	8	25.0
subroutine	11	11	100.0
pod	2	2	100.0
total	90	111	81.0

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__;