view release on metacpan or  search on metacpan

lib/Apache/ASP/State.pm  view on Meta::CPAN

package Apache::ASP::State;

use MLDBM;
use MLDBM::Sync 0.25;
use MLDBM::Sync::SDBM_File;
use SDBM_File;
use Data::Dumper;

use strict;
no strict qw(refs);
use vars qw(%DB %CACHE $DefaultGroupIdLength);
use Fcntl qw(:flock O_RDWR O_CREAT);
$DefaultGroupIdLength = 2;

# Database formats supports and their underlying extensions
%DB = (
       SDBM_File => ['.pag', '.dir'],
       DB_File => [''],
       'MLDBM::Sync::SDBM_File' => ['.pag', '.dir'],
       GDBM_File => [''],
       'Tie::TextDir' => [''],
       );

# About locking, we use a separate lock file from the SDBM files
# generated because locking directly on the SDBM files occasionally
# results in sdbm store errors.  This is less efficient, than locking
# to the db file directly, but having a separate lock file works for now.
#
# If there is no $group given, then the $group will be extracted from
# the $id as the first 2 letters of that group.
#
# If the group and the id are the same length, then what was passed
# was just a group id, and the object is being created for informational
# purposes only.  So, we don't create a lock file in this case, as this
# is not a real State object
#
sub new {
    my($asp, $id, $group) = @_;

    if($id) {
	$id =~ tr///;
    } else {
	$asp->Error("no id: $id passed into new State");
	return;
    }

    # default group is first 2 characters of id, simple hashing
    if($group) {
	$group =~ tr///;
    } else {
	$group = substr($id, 0, $DefaultGroupIdLength)
    }

    unless($group) {
	$asp->Error("no group defined for id $id");
	return;
    }

    my $state_dir = $asp->{state_dir};
    my $group_dir = $state_dir.'/'.$group;
    my $lock_file = $group_dir.'/'.$id.'.lock';
    my $file = $group_dir.'/'.$id;

    # we only need SDBM_File for internal, and its faster so use it
    my($state_db, $state_serializer);
    if($id eq 'internal') {
	$state_db = $Apache::ASP::DefaultStateDB;

lib/Apache/ASP/State.pm  view on Meta::CPAN

	     dbm => undef, 
	     'dir' => $group_dir,
	     id => $id, 
	     file => $file,
	     group => $group, 
	     group_dir => $group_dir,
	     reads => 0,
	     state_dir => $state_dir,
	     writes => 0,
	    };

    # short circuit before expensive directory tests for group stub
    if ($group eq $id) {
	return $self;
    }

    if($asp->config('StateAllWrite')) {
	$asp->{dbg} and $asp->{state_all_write} = 1;
	$self->{dir_perms} = 0777;
	$self->{file_perms} = 0666;
    } elsif($asp->config('StateGroupWrite')) {
	$asp->{dbg} and $asp->{state_group_write} = 1;
	$self->{dir_perms} = 0770;
	$self->{file_perms} = 0660;
    } else {
	$self->{dir_perms} = 0750;
	$self->{file_perms} = 0640;
    }

#    push(@{$self->{'ext'}}, @{$DB{$self->{state_db}}});    
#    $self->{asp}->Debug("db ext: ".join(",", @{$self->{'ext'}}));

    # create state directories
    my @create_dirs;
    unless(-d $state_dir) {
	push(@create_dirs, $state_dir);
    }
    # create group directory
    unless(-d $group_dir) {
	push(@create_dirs, $group_dir);
    }
    if(@create_dirs) {
	$self->UmaskClear;
	for my $create_dir (@create_dirs) {
#	    $create_dir =~ tr///; # this doesn't work to untaint with perl 5.6.1, use old method
	    $create_dir =~ /^(.*)$/s;
	    $create_dir = $1;
	    if(mkdir($create_dir, $self->{dir_perms})) {
		$asp->{dbg} && $asp->Debug("creating state dir $create_dir");
	    } else {
		my $error = $!;
		-d $create_dir || $self->{asp}->Error("can't create group dir $create_dir: $error");
	    }
	}
	$self->UmaskRestore;
    }

    # INIT MLDBM::Sync DBM
    { 
	local $MLDBM::UseDB = $state_db || 'SDBM_File';
	local $MLDBM::Serializer = $state_serializer || 'Data::Dumper';
	# clear current tied relationship first, if any
	$self->{dbm} = undef; 
	local $SIG{__WARN__} = sub {};
	
	my $error;
	$self->{file} =~ /^(.*)$/; # untaint
	$self->{file} = $1;
	local $MLDBM::RemoveTaint = 1;
	$self->{dbm} = &MLDBM::Sync::TIEHASH('MLDBM', $self->{file}, O_RDWR|O_CREAT, $self->{file_perms});
	$asp->{dbg} && $asp->Debug("creating dbm for file $self->{file}, db $MLDBM::UseDB, serializer: $MLDBM::Serializer");
	$error = $! || 'Undefined Error';


	if(! $self->{dbm}) {
	    $self->{asp}->Error(qq{
Cannot tie to file $self->{file}, $error !!
Make sure you have the permissions on the directory set correctly, and that your
version of Data::Dumper is up to date. Also, make sure you have set StateDir to 
to a good directory in the config file.  StateDir defaults to Global/.state
});
	}
    }

    $self;
}

sub Init   { shift->{dbm}->CLEAR(); }
sub Size   { shift->{dbm}->SyncSize; }
sub Delete { shift->{dbm}->CLEAR(); }
sub WriteLock { shift->{dbm}->Lock; }
sub ReadLock { shift->{dbm}->ReadLock; }
sub UnLock { shift->{dbm}->UnLock; }

sub DeleteGroupId {
    my $self = shift;

    my $group_dir = $self->{group_dir};
    if(-d $group_dir) {
	$self->{asp}{Internal}->LOCK;
	if(rmdir($group_dir)) {
	    $self->{asp}->Debug("deleting group dir $group_dir");
	} else {
	    $self->{asp}->Log("cannot delete group dir $group_dir: $!");
	}
	$self->{asp}{Internal}->UNLOCK;
    }
}

sub GroupId { shift->{group}; }

sub GroupMembers {
    my $self = shift;
    local(*DIR);
    my(%ids, @ids);

    unless(opendir(DIR, $self->{group_dir})) {
	$self->{asp}->Log("opening group $self->{group_dir} failed: $!");
	return [];
    }

    for(readdir(DIR)) {
	next if /^\.\.?$/;
	$_ =~ /^(.*?)(\.[^\.]+)?$/;
	next unless $1;
	$ids{$1}++;
    }

    # need to explicitly close directory, or we get a file
    # handle leak on Solaris
    closedir(DIR);

    # since not all sessions have their own dbms now, find session ids in $Internal too
    if(my $internal = $self->{asp}{Internal}) {
	my $cached_keys = {};
	unless($cached_keys = $self->{asp}{internal_cached_keys}) {
	    map {
		if(/^([0-9a-f]{2})/) { 
		    $cached_keys->{$1}{$_}++