view release on metacpan or  search on metacpan

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

    $state->WriteLock() if $asp->{session_serialize};
    $asp->Debug("tieing session $id");
    tie %self, 'Apache::ASP::Session',
    {
	state=>$state, 
	asp=>$asp, 
	id=>$id,
	started=>$started,
    };

    if($started) {
	$asp->{dbg} && $asp->Debug("clearing starting session");
	if($state->Size > 0) {
	    $asp->{dbg} && $asp->Debug("clearing data in old session $id");
	    %self = ();
	}
    }

    bless \%self;
}	

sub TIEHASH { 
    my($package, $self) = @_;
    bless $self;
}       

# stub so we don't have to test for it in autoload
sub DESTROY {
    my $self = shift;

    # wrapped in eval to suppress odd global destruction error messages
    # in perl 5.6.0, --jc 5/28/2001
    return unless eval { $self->{state} };

    $self->{state}->DESTROY;
    undef $self->{state};
    %$self = ();
}

# don't need to skip DESTROY since we have it here
# return if ($AUTOLOAD =~ /DESTROY/);
sub AUTOLOAD {
    my $self = shift;
    my $AUTOLOAD = $Apache::ASP::Session::AUTOLOAD;
    $AUTOLOAD =~ s/^(.*)::(.*?)$/$2/o;
    $self->{state}->$AUTOLOAD(@_);
}

sub FETCH {
    my($self, $index) = @_;

    # putting these comparisons in a regexp was a little
    # slower than keeping them in these 'eq' statements
    if($index eq '_SELF') {
	$self;
    } elsif($index eq '_STATE') {
	$self->{state};
    } elsif($index eq 'SessionID') {
	$self->{id};
    } elsif($index eq 'Timeout') {
	$self->Timeout();
    } else {
	$self->{state}->FETCH($index);
    }
}

sub STORE {
    my($self, $index, $value) = @_;
    if($index eq 'Timeout') {
	$self->Timeout($value);
    } else {	
	$self->{state}->STORE($index, $value);
    }
}

# firstkey and nextkey skip the _UA key so the user 
# we need to keep the ua info in the session db itself,
# so we are not dependent on writes going through to Internal
# for this very critical informatioh. _UA is used for security
# validation / the user's user agent.
sub FIRSTKEY {
    my $self = shift;
    my $value = $self->{state}->FIRSTKEY();
    if(defined $value and $value eq '_UA') {
	$self->{state}->NEXTKEY($value);
    } else {
	$value;
    }
}

sub NEXTKEY {
    my($self, $key) = @_;
    my $value = $self->{state}->NEXTKEY($key);
    if(defined($value) && ($value eq '_UA')) {
	$self->{state}->NEXTKEY($value);
    } else {
	$value;
    }	
}

sub CLEAR {
    my $state = shift->{state};
    my $ua = $state->FETCH('_UA');
    my $rv = $state->CLEAR();
    $ua && $state->STORE('_UA', $ua);
    $rv;
}

sub SessionID {
    my $self = shift;
    tied(%$self)->{id};
}

sub Timeout {
    my($self, $minutes) = @_;

    if(tied(%$self)) {
	$self = tied(%$self);
    }

    if($minutes) {
	$self->{asp}{Internal}->LOCK;
	my($internal_session) = $self->{asp}{Internal}{$self->{id}};
	$internal_session->{refresh_timeout} = $minutes * 60;
	$internal_session->{timeout} = time() + $minutes * 60;
	$self->{asp}{Internal}{$self->{id}} = $internal_session;
	$self->{asp}{Internal}->UNLOCK;
    } else {
	my($refresh) = $self->{asp}{Internal}{$self->{id}}{refresh_timeout};
	$refresh ||= $self->{asp}{session_timeout};
	$refresh / 60;
    }
}    

sub Abandon {
    shift->Timeout(-1);
}

sub TTL {
    my $self = shift;
    $self = tied(%$self);
    # time to live is current timeout - time... positive means
    # session is still active, returns ttl in seconds
    my $timeout = $self->{asp}{Internal}{$self->{id}}{timeout};
    my $ttl = $timeout - time();
}

sub Started {
    my $self = shift;
    tied(%$self)->{started};
}

# we provide these, since session serialize is not 
# the default... locking around writes will also be faster,
# since there will be only one tie to the database and 
# one flush per lock set
sub Lock { tied(%{$_[0]})->{state}->WriteLock(); }
sub UnLock { tied(%{$_[0]})->{state}->UnLock(); }

1;