#!/usr/people/cstross/bin/perl5
#
package CGI::State;
$CGI::DefaultClass = 'CGI::State';
$AutoloadClass = 'CGI';

$CGI::State::DEBUG = 0;
use Data::Dumper;
use Exporter;

@ISA = qw(CGI);
use FreezeThaw qw(freeze thaw);
use CGI::Carp;

$CGI::State::prefix = 'XXfreezestore_';

# @EXPORT = qw(new init_store put_store fetch_store del_store endform);

use strict;
no strict "refs";

=pod

Package name: CGI::State

Purpose: provide an OO mechanism  for storing perl data structures
inside a CGI object, passing them from one invocation to the next by
burying them in hidden fields. Makes it easy to pass hashes,
arrays, and more complex data structures (anything amenable to
being squished down by FreezeThaw).

Summary:

*  Uses FreezeThaw
*  Also uses Data::Dumper (if debugging is switched on)
*  Inherits everything from CGI.pm
*  Adds:
   -  init_store(storename, data_type)
   -  put_store(storename, entity)
   -  fetch_store(storename)
   -  del_store(storename)
   -  commit()
*  Overloads:
   - new()
   
How it works:

A CGI::State object is a CGI object by any other name. The main difference
is that it has one or more associated invisible "stores". A store is 
identified by name, and can be treated as a hash. init_store() creates
a new named store attached to the current object. put_store() puts the 
contents of a hashref into a store. fetch_store() returns a hashref 
containing the key:value items in the store. del_store() deletes a 
named store. new() automagically rebuilds any stores which were passed
from an HTML form, and commit() pumps 'em back out into the current form
before ending it.

Internally, a store is a frozen string stored in %{ $self->{.stores} }, 
where the key value is the store's name.

Because it uses FreezeThaw to handle stringified storage, it's possible 
to freeze complex data structures (but not globs or coderefs). At
present, you need to explciitly state whether a store is going to
contain an ARRAY, HASH, SCALAR or REF when you create it with 
init_store(). Don't even THINK about trying to use GLOB or CODE ...

The main point to note is that a store doesn't become persistent between
invocations of the CGI script unless the form is ended correctly, by
calling commit() before endform(). 

To prevent collisions with other named parameters in the CGI field
namespace, CGI::State prefixes its saved objects with whatever is
stored in $CGI::State::prefix (currently XXpersistent, but you can
override this if necessary).

For example:

  my ($q) = new CGI::State;
  print $q->startform();
  #
  # usual CGI.pm stuff goes here ...
  #
  my ($result) = $q->init_store("A");    # create a store called "A"
  $q->put_store("A", { qw( color blue 
                           taste sweet number 6) }); # stash data in "A"
  my ($handle) = $q->fetch_store("A");
  # $handle is a reference to a hash: {"color" => "blue", 
  #                                    "taste" => "sweet",
  #                                    "number" => "6"}
  #                                    
  $handle->{"quality"} = "poor"; # modify the contents of the hash
  $q->put_store("A", $handle);   # update the persistent store                                   
  #                                    
  $q->commit();   # export persistent data
  $q->endform();   # finish writing form

=cut

sub new {
    #
    # a CGI::State object is a CGI object with an additional hash called 
    # .store hanging off it.
    # 
    # To initialize it, we create a new CGI object, then import the data for
    # each store. Stores are named in the hidden field .store; they are
    # stored in hidden fields (corresponding to each name in .store)
    # 
    my($class,$initializer) = @_;
    my $self = new CGI;
    $CGI::State::DEBUG && print $self->header;
    $CGI::State::DEBUG && print $self->start_html;
    $self->{'.stores'} = {};
    bless $self, ref($class) || $class;
    my (@p) = $self->param();
    $CGI::State::DEBUG && print 'new(): params are [', join('][', @p), "]<BR>\n";
    if (grep(/$CGI::State::prefix/, @p) != 0) {
        # we have 1 or more stores
        my (@snames) = thaw($self->param($CGI::State::prefix));
        $CGI::State::DEBUG && print 'stores are named [', 
                               join('][', thaw($self->param($CGI::State::prefix))), 
                               "]<BR>\n";
        my ($sname) = "";      # scratch name of store being imported
        $self->delete($CGI::State::prefix); # get rid of old list of store names
        foreach $sname  (@snames) {
            # assemble stored name 
            my ($storename) = $CGI::State::prefix . $sname ;
            my ($tmpstore) = $self->param($storename); # import store contents      
            $CGI::State::DEBUG && print "read in store ",
                                        "$sname (Contents: $tmpstore)<P>\n"; 
            $self->delete($storename);       # delete hidden store field
            $self->{'.stores'}->{"$sname"} = $tmpstore;
        }
    }
    $CGI::State::DEBUG &&  print "<PRE>\n", Dumper($self), "</PRE>\n";
    return $self;
}


sub init_store($$$) {
   my ($self) = shift @_;
   my ($store) = shift @_;
   my ($type) = shift @_;
   # 
   # create a new store, named $storename
   # NB: nothing stored in it at this time
   # $type is the type of variable in the store -- scalar, array, hash, ref
   #
   # Return 1 if a store of this name already exists, 0 otherwise
   # 
   return 1 if ($self->{".stores"}->{$store} ne "");
   $self->{".stores"}->{$store} = freeze($type);
   $CGI::State::DEBUG && print $self->p("init_store():",
                               " self->{.stores}->{$store} == $type\n");
   return 0;
} 

sub put_store($$) {
   my ($self) = shift @_;
   my ($store) = shift @_;
   # 
   # puts a reference's contents in a named store, overwriting whatever's
   # already there.
   # 
   # parameters: a store and a reference to something
   # 
   # returns: 0 if successful, 1 otherwise
   my ($frozen) = "";
   my ($inputs) = shift @_;
   $CGI::State::DEBUG && print "put_store($self, $store, $inputs): <BR>";
   $CGI::State::DEBUG && print $self->pre(Dumper($self));
   if (ref $inputs) {
       $frozen = freeze($inputs) || do {
           return 1;
       };
       $self->{".stores"}->{$store} = $frozen;
   } else {
       $self->{".stores"}->{$store} = $inputs;
   }
   $CGI::State::DEBUG && print $self->pre(Dumper($self));
   return 0;
}

sub fetch_store($$) {
   my ($self) = shift @_;
   my ($store) = shift @_;
   # 
   # return a ref pointing to a copy of the named store's contents
   # on failure, return undef
   # 
   my (@thawed) = ();
     $CGI::State::DEBUG && print "fetch_store($store):<PRE>",
                                 Dumper($self), "</PRE><BR>\n";  
     if ($self->{'.stores'}->{$store} ne "") {
       my ($tmp) = $self->{'.stores'}->{$store};
       (@thawed ) = thaw($tmp);
       if (scalar(@thawed) == 1) {
           $CGI::State::DEBUG && print "working on [", 
                                        $thawed[0], "] which is a ",
                                        (ref($thawed[0]) || 'undef'),
                                        "<BR>\n";
           if (! ref ($thawed[0])) {
               if ($thawed[0] eq 'HASH') {
                   return {};
               } elsif ($thawed[0] eq 'ARRAY') {
                   return [];
               } elsif ($thawed[0] eq 'SCALAR') {
                   return "";
               } elsif ($thawed[0] eq 'REF') {
                   return \{};
               } 
           } else {
               return $thawed[0];       
           }
       } else {
           wantarray ? return @thawed    # fetch array of stored objs
                     : return undef ;     # error
       }
   } else {
       $CGI::State::DEBUG && print "fetch_store(): ",
                                   "self->{.stores}->{$store} is undefined<BR>\n";
       return undef; # error: no store of that name exists
   }
}

sub del_store($$) {
   my ($self) = shift @_;
   my ($store) = shift @_;
   # 
   # delete a named store
   # (return a reference to a hash containing its contents, just in case)
   # on failure, return undef
   #  
   if (defined ($self->{".stores"}->{$store})) {
       my ($contents) = $self->fetch_store($store);
       delete $self->{".stores"}->{$store};
       return $contents;
   } else {
       return undef;
   }
}

sub commit($) {
   my ($self) = shift @_;
   # 
   # Finish off the state, dumping the store contents into hidden variables.
   # Store contents are deleted after they're dumped.
   #
   my (@stack) = (); # stack of return values
   
   my (@snames) =keys ( %{$self->{".stores"}});
   # for each store, create a hidden field containing a flattened hash
   my ($store) = ""; # scratch name variable
   foreach $store (@snames) {
   $CGI::State::DEBUG && print "saved and deleted deleted store ",
                               "$store, with<BR>contents: \n",
                               $self->{".stores"}->{$store}, "<BR>\n";
       push(@stack,  $self->hidden(($CGI::State::prefix . $store), 
                     $self->{'.stores'}->{$store}));
      # delete the emptied-out store -- maybe
      # $self->del_store($store);
   }
   # now create a hidden field called .stores, containing a list of stores
   push (@stack, $self->hidden("$CGI::State::prefix", freeze(@snames)));
   $CGI::State::DEBUG && print "created hidden($CGI::State::prefix, [", 
                               join("][", @snames), "])\n";
   # delete the emitted store system
   $self->{".stores"} = undef;
   return @stack;
}
 
1;