view release on metacpan or  search on metacpan

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

                                                # 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 {
          $n--;
          printf "\r$n directories left             " unless $n % 256;
          print "\n" unless $n;
        };
    File::Path::mkpath($dir);
    make_dirs($dir,$levels,$feedback); # function for speed
  }

  sub make_dirs {
    my($dir, $levels, $feedback) = @_;
    $levels--;
    for (my $i=0; $i<256; $i++) {
      my $subdir = sprintf "%s/%02x", $dir, $i;
      -d $subdir or mkdir $subdir, 0755 or die "Couldn't mkdir $subdir: $!";
      $feedback->();
      make_dirs($subdir, $levels, $feedback) if $levels;
    }
  }

  sub storefilename {
    my $self    = shift;
    my $session = shift;
    die "The argument 'Directory' for object storage must be passed as an argument"
       unless defined $session->{args}{Directory};
    my $dir = $session->{args}{Directory};
    my $levels = $session->{args}{DirLevels} || 0;
    # here we depart from TreeStore:
    my $sessionID = $session->{data}{_session_id} or die "Got no session ID";
    my($host,$file) = $sessionID =~ /(?:([^:]+)(?::))?([\da-f]+)/;
    die "Too short ID part '$file' in session ID'" if length($file)<8;
    while ($levels) {
      $file =~ s|((..){$levels})|$1/|;
      $levels--;
    }
    "$dir/$file";
  }
}

# Counted is locked by definition
sub release_all_locks {
  return;
}

*get_lock_manager = \&release_all_locks;
*release_read_lock = \&release_all_locks;
*release_write_lock = \&release_all_locks;
*acquire_read_lock = \&release_all_locks;
*acquire_write_lock = \&release_all_locks;

sub TIEHASH {
  my $class = shift;

  my $session_id = shift;
  my $args       = shift || {};

  my $self = {
              args         => $args,

              data         => { _session_id => $session_id },
              # we always *have* read and write lock and need not care
              lock         => Apache::Session::READ_LOCK|Apache::Session::WRITE_LOCK,
              status       => 0,
              lock_manager => undef,
              generate     => undef,
              serialize    => \&Apache::Session::Serialize::Storable::serialize,
              unserialize  => \&Apache::Session::Serialize::Storable::unserialize,
            };

  bless $self, $class;
  $self->{object_store} = Apache::Session::CountedStore->new($self);

  #If a session ID was passed in, this is an old hash.
  #If not, it is a fresh one.

  if (defined $session_id) {
    $self->make_old;
    $self->restore; # calls materialize and unserialize via Apache::Session
    if (
        exists $self->{data} &&
        exists $self->{data}{_session_id} &&
        defined $self->{data}{_session_id} && # protect agains unini warning
        $session_id eq $self->{data}{_session_id}
       ) {
      # Fine. Validated. Kind of authenticated.
      # ready for a new session ID, keeping state otherwise.
      $self->make_modified if $self->{args}{AlwaysSave};
    } else {
      # oops, somebody else tried this ID, don't show him data.
      delete $self->{data};
      $self->make_new;
    }
  }
  # if we have no counterfile, we cannot generate an ID, that's OK:
  # this session will not need to be written.
  $self->{data}->{_session_id} = $self->generate_id() if
      $self->{args}{CounterFile};
  # no make_new here, session-ID doesn't count as data

  return $self;