HTML::Embperl::Session - HTML::Embperl::Session documentation

Embperl documentation Contained in the Embperl distribution.

Index

Code Index:

NAME

Top

HTML::Embperl::Session

DESCRIPTION

Top

An adaptation of Apache::Session to work with HTML::Embperl

SYNOPSIS

Top

Addtional Attributes for TIE

lazy

By Specifing this attribute, you tell Apache::Session to not do any access to the object store, until the first read or write access to the tied hash. Otherwise the tie function will make sure the hash exist or creates a new one.

create_unknown

Setting this to one causes Apache::Session to create a new session with the given id (or a new id, depending on recreate_id) when the specified session id does not exists. Otherwise it will die.

recreate_id

Setting this to one causes Apache::Session to create a new session id when the specified session id does not exists.

object_store

Specify the class for the object store. (The Apache::Session:: prefix is optional) Only for Apache::Session 1.00.

lock_manager

Specify the class for the lock manager. (The Apache::Session:: prefix is optional) Only for Apache::Session 1.00.

Store

Specify the class for the object store. (The Apache::Session::Store prefix is optional) Only for Apache::Session 1.5x.

Lock

Specify the class for the lock manager. (The Apache::Session::Lock prefix is optional) Only for Apache::Session 1.5x.

Generate

Specify the class for the id generator. (The Apache::Session::Generate prefix is optional) Only for Apache::Session 1.5x.

Serialize

Specify the class for the data serializer. (The Apache::Session::Serialize prefix is optional) Only for Apache::Session 1.5x.

Example using attrubtes to specfiy store and object classes instead of a derived class:

 use HTML::Embperl::Session;

 tie %session, 'HTML::Embperl::Session', undef,
    { 
    object_store => 'DBIStore',
    lock_manager => 'SysVSemaphoreLocker',
    DataSource => 'dbi:Oracle:db' 
    };

NOTE: HTML::Embperl::Session will require the nessecary additional perl modules for you.

Addtional Methods

setid

Set the session id for futher accesses.

getid

Get the session id. The difference to using $session{_session_id} is, that in lazy mode, getid will not create a new session id, if it doesn't exists.

cleanup

Writes any pending data, releases all locks and deletes all data from memory.

AUTHORS

Top

Gerald Richter <richter@dev.ecos.de> is the current maintainer.

This class was written by Jeffrey Baker (jeffrey@kathyandjeffrey.net) but it is taken wholesale from a patch that Gerald Richter (richter@ecos.de) sent me against Apache::Session.

Embperl documentation Contained in the Embperl distribution. 
#############################################################################
#
# HTML::Embperl::Session
# A bridge between Apache::Session and Embperl's %udat hash
# Copyright(c) 1999 Gerald Richter (richter@ecos.de)
# Copyright(c) 1998, 1999 Jeffrey William Baker (jeffrey@kathyandjeffrey.net)
# Distribute under the Artistic License
#
#############################################################################


package HTML::Embperl::Session;

use strict;
use vars qw(@ISA $VERSION);

$VERSION = '2.0.0';
@ISA = qw(Apache::Session);

use Apache::Session;

use constant NEW      => Apache::Session::NEW () ;
use constant MODIFIED => Apache::Session::MODIFIED () ;
use constant DELETED  => Apache::Session::DELETED () ;
use constant SYNCED   => Apache::Session::SYNCED () ;


sub TIEHASH {
    my $class = shift;
    
    my $session_id = shift;
    my $args       = shift || {};

    if(ref $args ne "HASH") 
        {
        die "Additional arguments should be in the form of a hash reference";
        }

    #Set-up the data structure and make it an object
    #of our class


    #$args -> {IDLength} ||= 32 ;
    my $self = 
        {
        args         => $args,
        data         => { _session_id => $session_id },
        initial_session_id => $session_id,
        lock         => 0,
        lock_manager => undef,
        object_store => undef,
        status       => 0,
        serialized   => undef,
        };
    
    bless $self, $class;

    $self -> require_modules ($args) ;

    $self -> init if (!$args -> {'lazy'}) ;


    return $self ;
    }


sub require_modules
    {
    my $self = shift ;
    my $args = shift ;

    # check object_store and lock_manager classes (Apache::Session 1.00)
    
    if ($args -> {'object_store'})
        {
        $args -> {'object_store'} = "Apache::Session::$args->{'object_store'}" if (!($args -> {'object_store'} =~ /::/)) ;
        eval "require $args->{'object_store'}" ;
        die "Cannot require $args->{'object_store'}" if ($@) ;
        }

    if ($args -> {'lock_manager'})
        {
        $args -> {'lock_manager'} = "Apache::Session::$args->{'lock_manager'}" if (!($args -> {'lock_manager'} =~ /::/)) ;
        eval "require $args->{'lock_manager'}" ;
        die "Cannot require $args->{'lock_manager'}" if ($@) ;
        }

    # check Store, Lock, Generate, Serialize classes (Apache::Session 1.5x)
    
    if ($args -> {'Store'})
        {
        $args -> {'Store'} = "Apache::Session::Store::$args->{'Store'}" if (!($args -> {'Store'} =~ /::/)) ;
        eval "require $args->{'Store'}" ;
        die "Cannot require $args->{'Store'}" if ($@) ;
        }

    if ($args -> {'Lock'})
        {
        $args -> {'Lock'} = "Apache::Session::Lock::$args->{'Lock'}" if (!($args -> {'Lock'} =~ /::/)) ;
        eval "require $args->{'Lock'}" ;
        die "Cannot require $args->{'Lock'}" if ($@) ;
        }

    if ($args -> {'Generate'})
        {
        $args -> {'Generate'} = "Apache::Session::Generate::$args->{'Generate'}" if (!($args -> {'Generate'} =~ /::/)) ;
        eval "require $args->{'Generate'}" ;
        die "Cannot require $args->{'Generate'}" if ($@) ;
        }

    if ($args -> {'Serialize'})
        {
        $args -> {'Serialize'} = "Apache::Session::Serialize::$args->{'Serialize'}" if (!($args -> {'Serialize'} =~ /::/)) ;
        eval "require $args->{'Serialize'}" ;
        die "Cannot require $args->{'Serialize'}" if ($@) ;
        }
    }





sub init
    {
    my $self = shift ;

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

    my $session_id = $self->{data}->{_session_id} ;

    if (!$session_id && $self -> {idfrom})
        {
        $session_id = $self->{data}->{_session_id} = &{$self->{generate}}($self, $self -> {idfrom})  ;
        }

    $self->{initial_session_id} ||= $session_id ;

    $self->populate;

    if (defined $session_id  && $session_id) 
        {
        #check the session ID for remote exploitation attempts
        #this will die() on suspicious session IDs.        

        eval { &{$self->{validate}}($self); } ;
        if (!$@)
            { # session id is ok        
            if (exists $self -> {'args'}->{Transaction} && $self -> {'args'}->{Transaction}) 
                {
                $self->acquire_write_lock;
                }

            $self->{status} &= ($self->{status} ^ NEW);

	    if ($self -> {'args'}{'create_unknown'})
	        {
                eval { $self -> restore } ;
	        #warn "Try to load session: $@" if ($@) ;
	        $@ = "" ;
	        $session_id = $self->{data}->{_session_id} ;
	        }
	    else
	        {
	        $self->restore;
	        }
            }
        }

    $@ = '' ;

    if (!($self->{status} & SYNCED))
        {
        $self->{status} |= NEW();
        if (!$self->{data}->{_session_id} || $self -> {'args'}{'recreate_id'})
            {
            if (exists ($self->{generate}))
                { # Apache::Session >= 1.50
	        $self->{data}->{_session_id} = &{$self->{generate}}($self)  ;
                }
            else
                {
	        $self->{data}->{_session_id} = $self -> generate_id() ;
                }
            }
        $self->save;
        }
    
    #warn "Session INIT $self->{initial_session_id};$self->{data}->{_session_id};" ;

    return $self;
    }

sub FETCH {
    my $self = shift;
    my $key  = shift;

    $self -> init if (!$self -> {'status'}) ;

    return $self->{data}->{$key};
}

sub STORE {
    my $self  = shift;
    my $key   = shift;
    my $value = shift;
    
    $self -> init if (!$self -> {'status'}) ;

    $self->{data}->{$key} = $value;
    
    $self->{status} |= MODIFIED;
    
    return $self->{data}->{$key};
}

sub DELETE {
    my $self = shift;
    my $key  = shift;
    
    $self -> init if (!$self -> {'status'}) ;

    $self->{status} |= MODIFIED;
    
    delete $self->{data}->{$key};
}

sub CLEAR {
    my $self = shift;

    $self -> init if (!$self -> {'status'}) ;

    $self->{status} |= MODIFIED;
    
    $self->{data} = {};
}

sub EXISTS {
    my $self = shift;
    my $key  = shift;
    
    $self -> init if (!$self -> {'status'}) ;

    return exists $self->{data}->{$key};
}

sub FIRSTKEY {
    my $self = shift;
    
    $self -> init if (!$self -> {'status'}) ;

    my $reset = keys %{$self->{data}};
    return each %{$self->{data}};
}

sub NEXTKEY {
    my $self = shift;
    
    $self -> init if (!$self -> {'status'}) ;

    return each %{$self->{data}};
}

sub DESTROY {
    my $self = shift;
    
    return if (!$self -> {'status'}) ;

    $self->save;
    $self->release_all_locks;
}

sub cleanup 
    {
    my $self = shift;
    
    $self->{initial_session_id} = undef ;
    if (!$self -> {'status'})
	{
	$self->{data} = {} ;
        $self->{serialized} = undef ;
	return ;
	}

    $self->save;
    {
    local $SIG{__WARN__} = 'IGNORE' ;
    local $SIG{__DIE__}  = 'IGNORE' ; 
    eval { $self -> {object_store} -> close } ; # Try to close file storage 
    $@ = "" ;
    }
    $self->release_all_locks;

    $self->{'status'} = 0 ;
    $self->{data} = {} ;
    $self->{serialized} = undef ;
    }


sub setid {
    my $self = shift;

    $self->{'status'} = 0 ;
    $self->{data}->{_session_id} = $self->{initial_session_id} = shift ;

}

sub setidfrom {
    my $self = shift;

    $self->{'status'} = 0 ;
    $self->{data}->{_session_id} = $self->{initial_session_id} = undef ;
    $self->{idfrom} = shift ;

}


sub getid {
    my $self = shift;

    return $self->{data}->{_session_id} || $self->{'ID'} ;
}

sub getids {
    my $self = shift;

    return ($self->{initial_session_id}, $self->{data}->{_session_id} || $self->{'ID'},  $self->{status} & MODIFIED) ;
}

sub delete {
    my $self = shift;
    
    return if ($self->{status} & NEW);
    
    $self->{initial_session_id} = "!DELETE" ;

    $self -> init if (!$self -> {'status'}) ;

    $self->{status} |= DELETED;
    $self->save;
    $self->{data} = {} ; # Throw away the data
}    


#
# For Apache::Session 1.00
#

sub get_object_store {
    my $self = shift;

    return new {$self -> {'args'}{'object_store'}} $self;
}

sub get_lock_manager {
    my $self = shift;
    
    return new {$self -> {'args'}{'lock_manager'}} $self;
}

#
# Default validate for Apache::Session < 1.53
#

sub validate {
    #This routine checks to ensure that the session ID is in the form
    #we expect.  This must be called before we start diddling around
    #in the database or the disk.

    my $session = shift;
    
    if ($session->{data}->{_session_id} !~ /^[a-fA-F0-9]+$/) {
        die;
    }
}

#
# For Apache::Session >= 1.50
#

sub populate 
    {
    my $self = shift;

    my $store = $self->{args}->{Store};
    my $lock  = $self->{args}->{Lock};
    my $gen   = $self->{args}->{Generate};
    my $ser   = $self->{args}->{Serialize};


    $self->{object_store} = new $store $self if ($store) ;
    $self->{lock_manager} = new $lock $self if ($lock);
    $self->{generate}     = \&{$gen . '::generate'} if ($gen);
    $self->{'validate'}     = \&{$gen . '::validate'} if ($gen && defined (&{$gen . '::validate'}));
    $self->{serialize}    = \&{$ser . '::serialize'} if ($ser);
    $self->{unserialize}  = \&{$ser . '::unserialize'} if ($ser) ;

    if (!defined ($self->{'validate'}))
        {
        $self->{'validate'} = \&validate ;
        }

    return $self;
    }



1 ;