cgi-session-user

[Mark S. <ma...@su...>]

--KDt/GgjP6HVcx58l
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

Here's a submission that didn't make it into 4.0.

I'm not sure I understand what it is good for. Comments from others are
welcome. 

    Mark

----- Forwarded message from Matt LeBlanc <mle...@cp...> -----

Date: Fri, 26 Aug 2005 15:28:55 -0500
From: Matt LeBlanc <mle...@cp...>
User-Agent: Mozilla Thunderbird 1.0.6 (Windows/20050716)
To: Mark Stosberg <mar...@cp...>
Subject: CGI::Session::Serialize::default


----- End forwarded message -----

--KDt/GgjP6HVcx58l
Content-Type: text/plain; charset=ISO-8859-1; format=flowed
Content-Disposition: inline

Mark,

I doubt this path will be seen as a very good addition to CGI::Session. 
However, I've written it and here it is.

This patch allows CGI::Sessions that use default as the serializer to 
actually store blessed items. If the object is overloaded, no worries. I 
tried several approaches to get around the fact that the objects were 
blessed in a Safe compartment. The coding style is...well...not pretty. 
Anyway, enjoy =P

Thanks,
Matt LeBlanc

--KDt/GgjP6HVcx58l
Content-Type: text/plain; charset=us-ascii;
	name="cgi-session-serialize-default.pm.diff"
Content-Disposition: inline; filename="cgi-session-serialize-default.pm.diff"

--- default.pm.orig	Fri Aug 26 14:34:37 2005
+++ default.pm	Fri Aug 26 15:22:58 2005
@@ -8,6 +8,8 @@
 use Safe;
 use Data::Dumper;
 use CGI::Session::ErrorHandler;
+use Scalar::Util qw(blessed reftype);
+use Carp "croak";
 
 @CGI::Session::Serialize::default::ISA = qw( CGI::Session::ErrorHandler );
 $CGI::Session::Serialize::default::VERSION = '1.4';
@@ -30,14 +32,53 @@
     my ($class, $string) = @_;
 
     # To make -T happy
-    my ($safe_string) = $string =~ m/^(.*)$/;
-    my $rv = Safe->new()->reval( $safe_string );
+    my ($safe_string) = $string =~ m/^(.*)$/s;
+    my $rv = Safe->new->reval( $safe_string );
     if ( my $errmsg = $@ ) {
         return $class->set_error("thaw(): couldn't thaw. $@");
     }
+    __walk($rv);
     return $rv;
 }
 
+sub __walk {
+    my %seen;
+    my @filter = shift;
+    
+    while (defined(my $x = shift @filter)) {
+        $seen{$x}++ and next;
+          
+        my $r = reftype $x or next;
+        if ($r eq "HASH") {
+            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);
+        }
+    }
+}
+
+sub __scan {
+    for (@_) {
+        if (blessed $_) {
+            if (overload::Overloaded($_)) {
+                my $r = reftype $_;
+                if ($r eq "HASH") {
+                    $_ = bless { %$_ }, ref $_
+                } elsif ($r eq "ARRAY") {
+                    $_ = bless [ @$_ ], ref $_
+                } elsif ($r eq "SCALAR" || $r eq "REF") {
+                    $_ = bless \do{my $o = $$_},ref $_
+                } else {
+                    croak "Do not know how to reconstitute blessed object of base type $r";
+                }
+            } else {
+                bless $_, ref $_
+            }
+        }
+    }
+}
 
 1;
 

--KDt/GgjP6HVcx58l--

----- End forwarded message -----
--
 . . . . . . . . . . . . . . . . . . . . . . . . . . . 
   Mark Stosberg            Principal Developer  
   ma...@su...     Summersault, LLC     
   765-939-9301 ext 202     database driven websites
 . . . . . http://www.summersault.com/ . . . . . . . .