view release on metacpan or  search on metacpan

SecureState.pm  view on Meta::CPAN

#Set this to 0 if you do not want CGI::SecureState to use flock() to assure that
#only one instance of CGI::SecureState is accessing the state file at a time.
#Leave this at 1 unless you really have a good reason not to.
$USE_FLOCK = 1;

#The operating systems below do not support flock, except for Windows NT systems,
#but it is impossible to distinguish WinNT systems from Win9x systems only based
#on $^O
local $_=$^O;
$USE_FLOCK = 0 if (/MacOS/i || /V[MO]S/i || /MSWin32/i);

#Workaround for Perl v5.005_03
$SEEK_SET = ($]<5.006) ? 0 : &Fcntl::SEEK_SET;
}

sub import {
    foreach (@_) {
	$NASTY_WARNINGS=0, next if (/[:-]?no_nasty_warnings/);
	$AVOID_SYMLINKS=0, next if (/[:-]?dont_avoid_symlinks/);
	$USE_FLOCK=0,      next if (/[:-]?no_flock/);
	$USE_FLOCK=1,      next if (/[:-]?use_flock/);
	if (/[:-]?(extra|paranoid|no)_secure/) {
	    $CGI::PRIVATE_TEMPFILES = ! /no_/;
	    $CGI::POST_MAX = /no_/ ? -1 : 10240;
	    $CGI::DISABLE_UPLOADS = /paranoid_/;
	}
    }
}


sub new
{
    #Obtain the class (should be CGI::SecureState in most cases)
    my $class = shift;

    #populate the argument array
    my %args = args_to_hash([qw(-stateDir -mindSet -memory -temp -key)], @_);

    #Set up the CGI object to our liking
    my $cgi=new CGI;

    #We don't want any nassssty tricksssy people playing with things that we
    #should be setting ourselves
    $cgi->delete($_) foreach (qw(.statefile .cipher .isforgetful .memory
				 .recent_memory .age .errormsg));

    #if the user has an error message subroutine, we should use it:
    $cgi->{'.errormsg'} = $args{'-errorSub'} || $args{'-errorsub'} || undef;

    #set the forgetfulness;  By default, this is "forgetful" because it encourages
    #cleaner programming, but if the user is upgrading from 0.2x series, this will be
    #undef; if so, be backwards-compatible but give them a few nasty warning messages.
    $args{'-mindSet'} = $args{'-mindset'} unless (defined $args{'-mindSet'});
    $cgi->{'.isforgetful'} = $args{'-mindSet'};

    if (defined $args{'-mindSet'}) {
	$cgi->{'.isforgetful'} = 0 if ($args{'-mindSet'} =~ /unforgetful/i);
    } elsif ($NASTY_WARNINGS) {
	warn "Programmer did not set mindset when declaring new CGI::SecureState object at ",
	    (caller)[1], " line ", (caller)[2], ".  Please tell him/her to read the new CGI::SecureState ",
	    "documentation.\n";
    }

    #Set up long-term memory
    $args{'-memory'} ||= $args{'-longTerm'} || $args{'-longterm'} || [];
    $cgi->{'.memory'} = {map {$_ => 1} @{$args{'-memory'}}};

    #Set up short-term memory
    $args{'-temp'} ||= $args{'-shortTerm'} || $args{'-shortterm'} || [];
    $cgi->{'.recent_memory'} = {map {$_ => undef} @{$args{'-temp'}}};

    #Check for ID tag in url if it is not in the normal parameters list
    if (!defined($cgi->param('.id')) && $cgi->request_method() eq 'POST') {
	$cgi->param('.id', $cgi->url_param('.id'));
    }

    #Set up the encryption part
    my $id = $cgi->param('.id') || sha1_hex($args{'-key'} or generate_id());
    my $remote_addr = $cgi->remote_addr();
    my $remoteip = pack("CCCC", split (/\./, $remote_addr));
    my $key = pack("H*",$id) . $remoteip;
    $cgi->{'.cipher'} = new Crypt::Blowfish($key) || errormsg($cgi, 'invalid state file');

    #set the directory where we will store saved information
    my $statedir = $args{'-stateDir'} || $args{'-statedir'} || ".";

    #Set up (and untaint) the name of the location to store data
    my $statefile = sha1_base64($id.$remote_addr);
    $statefile =~ tr|+/|_-|;
    $statefile =~ /([\w-]{27})/;
    $cgi->{'.statefile'} = File::Spec->catfile($statedir,$1);

    #convert $cgi into a CGI::SecureState object
    bless $cgi, $class;

    #if this is not a new session, attempt to read from the state file
    $cgi->param('.id') ? $cgi->recover_memory : $cgi->param('.id' => $id);

    #save any changes to the state file; if there are none, then update only the timestamp
    my $newmemory = (@{$args{'-memory'}}) ? 1 : 0;
    ($newmemory || !$cgi->{'.isforgetful'}) ? $cgi->save_memory : $cgi->encipher;

    #finish
    return $cgi;
}

sub add {
    my $self = shift;
    my %params = (ref($_[1]) eq 'ARRAY') ? @_ : (shift, \@_);
    $self->param($_, @{$params{$_}}) foreach (keys %params);
    $self->remember(keys %params);
}

sub remember {
    my $self = shift;
    my ($isforgetful,$memory) = @$self{'.isforgetful','.memory'};
    $isforgetful ? $memory->{$_}=1 : delete($memory->{$_}) foreach (@_);
    $self->save_memory;
}