view release on metacpan or  search on metacpan

lib/Apache/Session/Counted.pm  view on Meta::CPAN

{
  package Apache::Session::CountedStore;
  use Symbol qw(gensym);

  use strict;

  sub new { bless {}, shift }

  # write. Note that we alias insert and update
  sub update {
    my $self    = shift;
    my $session = shift;
    my $storefile = $self->storefilename($session);
    my $fh = gensym;
    unless ( open $fh, ">$storefile\0" ) {
      warn qq{A:S:Counted: Could not open file $storefile for writing: $!
Maybe you haven't initialized the storage directory with
 use Apache::Session::Counted;
 Apache::Session::CountedStore->tree_init("$session->{args}{Directory}","$session->{args}{DirLevels}");
I'm trying to band-aid by creating this directory};
      require File::Basename;
      my $dir = File::Basename::dirname($storefile);
      require File::Path;
      File::Path::mkpath($dir);
      warn "A:S:Counted: mkdir on directory $dir successfully done.";
    }
    if ( open $fh, ">$storefile\0" ) {
      print $fh $session->{serialized}; # $fh->print might fail in some perls
      close $fh;
    } else {
      die "Giving up. Could not open file $storefile for writing: $!";
    }
  }
  *insert = \&update;

  # retrieve
  sub materialize {
    my $self    = shift;
    my $session = shift;
    my $sessionID = $session->{data}{_session_id} or die "Got no session ID";
    my($host) = $sessionID =~ /(?:([^:]+)(?::))/;
    my($content);

    if ($host &&
        $session->{args}{HostID} &&
        $session->{args}{HostID} ne $host
       ) {
      # warn sprintf("configured hostID[%s]host from argument[%s]",
      #              $session->{args}{HostID},
      #              $host);
      my $surl;
      if (exists $session->{args}{HostURL}) {
        $surl = $session->{args}{HostURL}->($host,$sessionID);
      } else {
        $surl = sprintf "http://%s/?SESSIONID=%s", $host, $sessionID;
      }
      # warn "surl[$surl]";
      if ($surl) {
        require LWP::UserAgent;
        require HTTP::Request::Common;
        my $ua = LWP::UserAgent->new;
        $ua->timeout($session->{args}{Timeout} || 10);
        my $req = HTTP::Request::Common::GET $surl;
        my $result = $ua->request($req);
        if ($result->is_success) {
          $content = $result->content;
        } else {
          $content = Storable::nfreeze {};
        }
      } else {
        $content = Storable::nfreeze {};
      }
      $session->{serialized} = $content;
      return;
    }

    my $storefile = $self->storefilename($session);
    my $fh = gensym;
    if ( open $fh, "<$storefile\0" ) {
      local $/;
      $session->{serialized} = <$fh>;
      close $fh or die $!;
      if ($content && $content ne $session->{serialized}) {
        warn "A:S:Counted: content and serialized are NOT equal";
        require Dumpvalue;
        my $dumper = Dumpvalue->new;
        $dumper->set(unctrl => "quote");
        warn sprintf "A:S:Counted: content[%s]serialized[%s]",
            $dumper->stringify($content),
                $dumper->stringify($session->{serialized});
      }
    } else {
      warn "A:S:Counted: Could not open file $storefile for reading: $!";
      $session->{data} = {};
      $session->{serialized} = $session->{serialize}->($session);
    }
  }

  sub remove {
    warn "A:S:Counted: remove not implemented"; # doesn't make sense
                                                # for our concept of a
                                                # session
    return;

    my $self    = shift;
    my $session = shift;
    my $storefile = $self->storefilename($session);
    unlink $storefile or
        warn "A:S:Counted: Object $storefile does not exist in the data store";
  }

  sub tree_init {
    my $self    = shift;
    my $dir = shift;
    my $levels = shift;
    my $n = 0x100 ** $levels;
#    warn "A:S:Counted: Creating directory $dir
# and $n subdirectories in $levels level(s)\n";
#    warn "A:S:Counted: This may take a while\n" if $levels>1;
    require File::Path;
    $|=1;
    my $feedback =
        sub {