Apache::Session::Wrapper - A simple wrapper around Apache::Session

 my $wrapper =
     Apache::Session::Wrapper->new( class  => 'MySQL',
                                    handle => $dbh,
                                    cookie_name => 'example-dot-com-cookie',
                                  );

 # will get an existing session from a cookie, or create a new session
 # and cookie if needed
 $wrapper->session->{foo} = 1;

  Apache::Session::Wrapper->RegisterClass
      ( name     => 'MyClass',
        required => [ [ qw( param1 param2 ) ],
                      [ qw( param3 param4 ) ] ],
        optional => [ 'optional_p' ],
      );

  Apache::Session::Wrapper->RegisterClass
      ( name     => 'Apache::Session::MyFile',
        required => 'File',
        optional => 'File',
      );

  Apache::Session::Wrapper->RegisterFlexClass
      ( name     => 'MyClass',
        type     => 'Store',
        required => [ [ qw( param1 param2 ) ],
                      [ qw( param3 param4 ) ] ],
        optional => [ 'optional_p' ],
      );

  Apache::Session::Wrapper->RegisterFlexClass
      ( name     => 'Apache::Session::Store::MyFile',
        type     => 'store',
        required => 'File',
        optional => 'File',
      );

package Apache::Session::Wrapper;

use strict;

use vars qw($VERSION);

$VERSION = '0.34';
$VERSION = eval $VERSION;

use base qw(Class::Container);

use Apache::Session 1.81;

use Exception::Class ( 'Apache::Session::Wrapper::Exception::NonExistentSessionID' =>
		       { description => 'A non-existent session id was used',
			 fields => [ 'session_id' ] },
                       'Apache::Session::Wrapper::Exception::Params' =>
		       { description => 'An invalid parameter or set of parameters was given',
                         alias => 'param_error' },
		     );

use Params::Validate 0.70;
use Params::Validate qw( validate SCALAR UNDEF BOOLEAN ARRAYREF OBJECT );
Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } );

use Scalar::Util ();


my $MOD_PERL = _find_mp_version();
sub _find_mp_version
{
    return 0 unless $ENV{MOD_PERL};

    return
        ( $ENV{MOD_PERL} =~ /(?:1\.9|2\.\d)/
          ? 2
          : 1
        );
}

my @HeaderMethods = qw( err_headers_out headers_out );

my %params =
    ( always_write =>
      { type => BOOLEAN,
	default => 1,
	descr => 'Whether or not to force a write before the session goes out of scope' },

      allow_invalid_id =>
      { type => BOOLEAN,
	default => 1,
	descr => 'Whether or not to allow a failure to find an existing session id' },

      param_name =>
      { type => SCALAR,
        optional => 1,
        depends => 'param_object',
	descr => 'Name of the parameter to use for session tracking' },

      param_object =>
      { type => OBJECT,
        optional => 1,
        can  => 'param',
	descr => 'Object which has a "param" method, to be used for getting the session id from a query string or POST argument' },

      use_cookie =>
      { type => BOOLEAN,
	default => 0,
	descr => 'Whether or not to use a cookie to track the session' },

      cookie_name =>
      { type => SCALAR,
	default => 'Apache-Session-Wrapper-cookie',
	descr => 'Name of cookie used by this module' },

      cookie_expires =>
      { type => UNDEF | SCALAR,
	default => '+1d',
	descr => 'Expiration time for cookies' },

      cookie_domain =>
      { type => UNDEF | SCALAR,
        optional => 1,
	descr => 'Domain parameter for cookies' },

      cookie_path =>
      { type => SCALAR,
	default => '/',
	descr => 'Path for cookies' },

      cookie_secure =>
      { type => BOOLEAN,
	default => 0,
	descr => 'Are cookies sent only for SSL connections?' },

      cookie_resend =>
      { type => BOOLEAN,
	default => 1,
	descr => 'Resend the cookie on each request?' },

      header_object =>
      { type => OBJECT,
        callbacks =>
        { 'has a method to set headers' =>
          sub { grep { $_[0]->can($_) } @HeaderMethods } },
        optional => 1,
        descr => 'An object that can be used to send cookies with' },

      class =>
      { type => SCALAR,
	descr => 'An Apache::Session class to use for sessions' },

      data_source =>
      { type => SCALAR,
	optional => 1,
	descr => 'The data source when using MySQL or PostgreSQL' },

      user_name =>
      { type => UNDEF | SCALAR,
        optional => 1,
	descr => 'The user name to be used when connecting to a database' },

      password =>
      { type => UNDEF | SCALAR,
	default => undef,
	descr => 'The password to be used when connecting to a database' },

      table_name =>
      { type => UNDEF | SCALAR,
        optional => 1,
        descr => 'The table in which sessions are saved' },

      lock_data_source =>
      { type => SCALAR,
	optional => 1,
	descr => 'The data source when using MySQL or PostgreSQL' },

      lock_user_name =>
      { type => UNDEF | SCALAR,
        optional => 1,
	descr => 'The user name to be used when connecting to a database' },

      lock_password =>
      { type => UNDEF | SCALAR,
	default => undef,
	descr => 'The password to be used when connecting to a database' },

      handle =>
      { type => OBJECT,
        optional => 1,
	descr => 'An existing database handle to use' },

      lock_handle =>
      { type => OBJECT,
        optional => 1,
	descr => 'An existing database handle to use' },

      commit =>
      { type => BOOLEAN,
        default => 1,
	descr => 'Whether or not to auto-commit changes to the database' },

      transaction =>
      { type => BOOLEAN,
	default => 0,
	descr => 'The Transaction flag for Apache::Session' },

      directory =>
      { type => SCALAR,
	optional => 1,
	descr => 'A directory to use when storing sessions' },

      lock_directory =>
      { type => SCALAR,
	optional => 1,
	descr => 'A directory to use for locking when storing sessions' },

      file_name =>
      { type => SCALAR,
	optional => 1,
	descr => 'A DB_File to use' },

      store =>
      { type => SCALAR,
	optional => 1,
	descr => 'A storage class to use with the Flex module' },

      lock =>
      { type => SCALAR,
	optional => 1,
	descr => 'A locking class to use with the Flex module' },

      generate =>
      { type => SCALAR,
	default => 'MD5',
	descr => 'A session generator class to use with the Flex module' },

      serialize =>
      { type => SCALAR,
	optional => 1,
	descr => 'A serialization class to use with the Flex module' },

      textsize =>
      { type => SCALAR,
	optional => 1,
	descr => 'A parameter for the Sybase storage module' },

      long_read_len =>
      { type => SCALAR,
	optional => 1,
	descr => 'A parameter for the Oracle storage module' },

      n_sems =>
      { type => SCALAR,
	optional => 1,
	descr => 'A parameter for the Semaphore locking module' },

      semaphore_key =>
      { type => SCALAR,
	optional => 1,
	descr => 'A parameter for the Semaphore locking module' },

      mod_usertrack_cookie_name =>
      { type => SCALAR,
	optional => 1,
	descr => 'The cookie name used by mod_usertrack' },

      save_path =>
      { type => SCALAR,
	optional => 1,
	descr => 'Path used by Apache::Session::PHP' },

      session_id =>
      { type => SCALAR,
	optional => 1,
	descr => 'Try this session id first when making a session' },
    );

# What set of parameters are required for each session class.
# Multiple array refs represent multiple possible sets of parameters
my %ApacheSessionParams =
    ( Flex     => [ [ qw( store lock generate serialize ) ] ],
      MySQL    => [ [ qw( data_source user_name
                          lock_data_source lock_user_name ) ],
		    [ qw( handle lock_handle ) ] ],
      Postgres => [ [ qw( data_source user_name commit ) ],
		    [ qw( handle commit ) ] ],
      File     => [ [ qw( directory lock_directory ) ] ],
      DB_File  => [ [ qw( file_name lock_directory ) ] ],

      PHP      => [ [ qw( save_path ) ] ],
    );

@ApacheSessionParams{ qw( Informix Oracle Sybase ) } =
    ( $ApacheSessionParams{Postgres} ) x 3;

my %OptionalApacheSessionParams =
    ( MySQL    => [ [ qw( table_name password lock_password ) ] ],
      Postgres => [ [ qw( table_name password ) ] ],
      Informix => [ [ qw( table_name password ) ] ],
      Oracle   => [ [ qw( long_read_len table_name password ) ] ],
      Sybase   => [ [ qw( textsize table_name password ) ] ],
    );

my %ApacheSessionFlexParams =
    ( store =>
      { MySQL    => [ [ qw( data_source user_name ) ],
		      [ qw( handle ) ] ],
	Postgres => $ApacheSessionParams{Postgres},
	File     => [ [ qw( directory ) ] ],
	DB_File  => [ [ qw( file_name ) ] ],
	PHP      => $ApacheSessionParams{PHP},
      },
      lock =>
      { MySQL     => [ [ qw( lock_data_source lock_user_name ) ],
		       [ qw( lock_handle ) ] ],
	File      => [ [ ] ],
	Null      => [ [ ] ],
	Semaphore => [ [ ] ],
      },
      generate =>
      { MD5          => [ [ ] ],
	ModUniqueId  => [ [ ] ],
	ModUsertrack => [ [ qw( mod_usertrack_cookie_name )  ] ],
      },
      serialize =>
      { Storable => [ [ ] ],
	Base64   => [ [ ] ],
	Sybase   => [ [ ] ],
	UUEncode => [ [ ] ],
	PHP      => [ [ ] ],
      },
    );

@{ $ApacheSessionFlexParams{store} }{ qw( Informix Oracle Sybase ) } =
    ( $ApacheSessionFlexParams{store}{Postgres} ) x 3;

my %OptionalApacheSessionFlexParams =
    ( store => { map { $_ => $OptionalApacheSessionParams{$_} }
                 qw( MySQL Postgres Informix Oracle Sybase ) },
    );

sub _SetValidParams {
    my $class = shift;

    my %extra;
    for my $hash ( \%ApacheSessionParams,
                   \%OptionalApacheSessionParams,
                   @ApacheSessionFlexParams{ qw( store lock generate serialize ) },
                   @OptionalApacheSessionFlexParams{ qw( store lock generate serialize ) },
                 )
    {
        for my $p ( map { @$_ } map { @$_ } values %$hash )
        {
            my $h;
            if ( ref $p ) {
                # we assume its a hash of names/parameter specifications
                $h = $p;
            } elsif (!$params{$p}) {
                # its a new parameter defined by a scalar, default to SCALAR value
                $h = { $p => { optional => 1, type => SCALAR } };
            } else {
                # its a scalar option we already know.
                next;
            }
            # now expand the options
            foreach my $name (keys %$h) {
                next if $params{$name};
                $extra{$p} = $h->{$name};
            }
        }
    }

    $class->valid_params( %extra, %params );
    $class->SetStudlyForms();
}
__PACKAGE__->_SetValidParams();

my %StudlyForm;
sub SetStudlyForms
{
    %StudlyForm =
        ( map { $_ => _studly_form($_) }
          map { ref $_ ? @$_ :$_ }
          map { @$_ }
          ( values %ApacheSessionParams ),
          ( values %OptionalApacheSessionParams ),
          ( map { values %{ $ApacheSessionFlexParams{$_} } }
            keys %ApacheSessionFlexParams ),
          ( map { values %{ $OptionalApacheSessionFlexParams{$_} } }
            keys %OptionalApacheSessionFlexParams ),
        );

    # why Apache::Session does this I do not know
    $StudlyForm{textsize} = 'textsize';
}

sub _studly_form
{
    my $string = shift;
    $string =~ s/(?:^|_)(\w)/\U$1/g;
    return $string;
}

sub RegisterClass {
    my $class = shift;
    my %p = validate( @_, { name => { type => SCALAR },
                            required => { type => SCALAR | ARRAYREF, default => [ [ ] ] },
                            optional => { type => SCALAR | ARRAYREF, default => [ ] },
                          },
                    );

    $p{name} =~ s/^Apache::Session:://;

    $ApacheSessionParams{ $p{name} } =
        ( ref $p{required}
          ? $p{required}
          : $ApacheSessionParams{ $p{required} }
        );

    $OptionalApacheSessionParams{ $p{name} } =
        ( ref $p{optional}
          ? [ $p{optional} ]
          : $OptionalApacheSessionParams{ $p{optional} }
        );

    $class->_SetValidParams();
}

sub RegisterFlexClass {
    my $class = shift;
    my %p = validate( @_, { type => { type => SCALAR,
                                      regex => qr/^(?:store|lock|generate|serialize)/,
                                    },
                            name => { type => SCALAR },
                            required => { type => SCALAR | ARRAYREF, default => [ [ ] ] },
                            optional => { type => SCALAR | ARRAYREF, default => [ ]  },
                          },
                    );

    $p{name} =~ s/^Apache::Session:://;
    $p{name} =~ s/^\Q$p{type}\E:://i;

    $ApacheSessionFlexParams{ $p{type} }{ $p{name} } =
        ( ref $p{required}
          ? $p{required}
          : $ApacheSessionFlexParams{ $p{type} }{ $p{required} }
        );

    $OptionalApacheSessionFlexParams{ $p{type} }{ $p{name} } =
        ( ref $p{optional}
          ? [ $p{optional} ]
          : $OptionalApacheSessionFlexParams{ $p{type} }{ $p{optional} }
        );

    $class->_SetValidParams();
}

sub new
{
    my $class = shift;
    my %p = @_;

    my $self = $class->SUPER::new(%p);

    $self->_check_session_params;
    $self->_set_session_params;

    if ( $self->{use_cookie} && ! ( $ENV{MOD_PERL} || $self->{header_object} ) )
    {
        param_error
            "The header_object parameter is required in order to use cookies outside of mod_perl";
    }

    my $session_class = "Apache::Session::$self->{session_class_piece}";
    unless ( $session_class->can('TIEHASH') )
    {
        eval "require $session_class";
        die $@ if $@;
    }

    $self->_make_session( $p{session_id} );

    $self->_bake_cookie
        if $self->{use_cookie} && ! $self->{cookie_is_baked};

    return $self;
}

sub _check_session_params
{
    my $self = shift;

    $self->{session_class_piece} = $self->{class};
    $self->{session_class_piece} =~ s/^Apache::Session:://;

    my $sets = $ApacheSessionParams{ $self->{session_class_piece} }
	or param_error "Invalid session class: $self->{class}";

    $self->_check_sets( $sets, 'session', $self->{class} )
        if grep { @$_ } @$sets;

    if ( $self->{session_class_piece} eq 'Flex' )
    {
	foreach my $key ( keys %ApacheSessionFlexParams )
	{
	    my $subclass = $self->{$key};
	    my $sets = $ApacheSessionFlexParams{$key}{$subclass}
		or param_error "Invalid class for $key: $self->{$key}";

            $self->_check_sets( $sets, $key, $subclass )
                if grep { @$_ } @$sets;
	}
    }
}

sub _check_sets
{
    my $self = shift;
    my $sets = shift;
    my $type = shift;
    my $class = shift;

    my @missing;
    foreach my $set (@$sets)
    {
        my @matched = grep { exists $self->{$_} } @$set;

        return if @matched == @$set;

        @missing = grep { ! exists $self->{$_} } @$set;
    }

    param_error "Some or all of the required parameters for your chosen $type class ($class) were provided."
                . "  The following parameters were missing: @missing\n";
}

sub _set_session_params
{
    my $self = shift;

    my %params;

    $self->_sets_to_params
	( $ApacheSessionParams{ $self->{session_class_piece} },
	  \%params );

    $self->_sets_to_params
	( $OptionalApacheSessionParams{ $self->{session_class_piece} },
	  \%params );


    if ( $self->{session_class_piece} eq 'Flex' )
    {
	foreach my $key ( keys %ApacheSessionFlexParams )
	{
	    my $subclass = $self->{$key};
	    $params{ $StudlyForm{$key} } = $subclass;

	    $self->_sets_to_params
		( $ApacheSessionFlexParams{$key}{$subclass},
		  \%params );

	    $self->_sets_to_params
		( $OptionalApacheSessionFlexParams{$key}{$subclass},
		  \%params );
	}
    }

    $self->{params} = \%params;

    $self->_set_cookie_fields
        if $self->{use_cookie};
}

sub _set_cookie_fields
{
    my $self = shift;

    my $cookie_class;
    if ($MOD_PERL)
    {
        $cookie_class =
            $MOD_PERL == 2 ? 'Apache2::Cookie' : 'Apache::Cookie';

        eval "require $cookie_class"
            unless $cookie_class->can('new');
    }

    unless ( $cookie_class && $cookie_class->can('new' ) )
    {
        require CGI::Cookie;
        $cookie_class = 'CGI::Cookie';
    }

    $self->{cookie_class} = $cookie_class;

    if ( $self->{cookie_class} eq 'CGI::Cookie' )
    {
        $self->{new_cookie_args} = [];
        $self->{fetch_cookie_args} = [];
    }
    else
    {
        $self->{new_cookie_args} =
            [ $MOD_PERL == 2
              ? Apache2::RequestUtil->request
              : Apache->request
            ];

        $self->{fetch_cookie_args} =
            ( $MOD_PERL == 2
              ? $self->{new_cookie_args}
              : []
            );
        $self->{bake_cookie_args} =
            ( $MOD_PERL == 2
              ? $self->{new_cookie_args}
              : []
            );
    }
}

sub _sets_to_params
{
    my $self = shift;
    my $sets = shift;
    my $params = shift;

    foreach my $set (@$sets)
    {
	foreach my $key (@$set)
	{
	    if ( exists $self->{$key} )
	    {
		$params->{ $StudlyForm{$key} } =
		    $self->{$key};
	    }
	}
    }
}

sub _make_session
{
    my $self = shift;
    my $session_id = shift;

    return if
        defined $session_id && $self->_try_session_id( $session_id );

    my $id = $self->_get_session_id;
    return if defined $id && $self->_try_session_id($id);

    if ( defined $self->{param_name} )
    {
        my $id = $self->_get_session_id_from_args;

        return if defined $id && $self->_try_session_id($id);
    }

    if ( $self->{use_cookie} )
    {
        my $id = $self->_get_session_id_from_cookie;

        if ( defined $id && $self->_try_session_id($id) )
        {
            $self->{cookie_is_baked} = 1
                unless $self->{cookie_resend};

            return;
        }
    }

    # make a new session id
    $self->_try_session_id(undef);
}

# for subclasses
sub _get_session_id { return }

sub _get_session_id_from_args
{
    my $self = shift;

    return $self->{param_object}->param( $self->{param_name} );
}

sub _get_session_id_from_cookie
{
    my $self = shift;

    if ( $MOD_PERL == 2 )
    {
        my $jar = Apache2::Cookie::Jar->new( @{ $self->{fetch_cookie_args} } );
        my $c   = $jar->cookies( $self->{cookie_name} );
        return $c->value if $c;
    }
    else
    {
        my %c = $self->{cookie_class}->fetch( @{ $self->{fetch_cookie_args} } );

        return $c{ $self->{cookie_name} }->value
            if exists $c{ $self->{cookie_name} };
    }
    return undef;
}

sub _try_session_id
{
    my $self = shift;
    my $session_id = shift;

    return 1 if ( $self->{session} &&
                  defined $session_id &&
                  $self->{session_id} eq $session_id );

    my %s;
    {
	local $SIG{__DIE__};
	eval
	{
	    tie %s, "Apache::Session::$self->{session_class_piece}",
                $session_id, $self->{params};
	};

        if ( $@ || ! tied %s || ! $s{_session_id} )
        {
            $self->_handle_tie_error( $@, $session_id );
            return;
        }
    }

    untie %{ $self->{session} } if $self->{session};

    $self->{session} = \%s;
    $self->{session_id} = $s{_session_id};

    $self->{cookie_is_baked} = 0;

    return 1;
}

sub _handle_tie_error
{
    my $self = shift;
    my $err = shift;
    my $session_id = shift;

    if ( $err =~ /Object does not exist/ && defined $session_id )
    {
        return if $self->{allow_invalid_id};

        Apache::Session::Wrapper::Exception::NonExistentSessionID->throw
            ( error => "Invalid session id: $session_id",
              session_id => $session_id );
    }
    else
    {
        my $error =
            $err ? $err : "Tying to Apache::Session::$self->{session_class_piece} failed but did not throw an exception";
        die $error;
    }
}

sub _bake_cookie
{
    my $self = shift;

    my $expires = shift || $self->{cookie_expires};
    $expires = undef if defined $expires && $expires =~ /^session$/i;

    my $domain = $self->{cookie_domain};

    my $cookie =
        $self->{cookie_class}->new
            ( @{ $self->{new_cookie_args} },
              -name    => $self->{cookie_name},
              # Apache2::Cookie will return undef if we pass undef for
              # -value.
              -value   => ( $self->{session_id} || '' ),
              ( defined $expires
                ? ( -expires => $expires )
                : ()
              ),
              ( defined $domain
                ? ( -domain  => $domain )
                : ()
              ),
              -path    => $self->{cookie_path},
              -secure  => $self->{cookie_secure},
            );

    # If not running under mod_perl, CGI::Cookie->bake() will call
    # print() to send a cookie header right now, which may not be what
    # the user wants.
    if ( $cookie->can('bake') && ! $cookie->isa('CGI::Cookie') )
    {
        $cookie->bake( @{ $self->{bake_cookie_args} } );
    }
    else
    {
        my $header_object = $self->{header_object};
        for my $meth (@HeaderMethods)
        {
            if ( $header_object->can($meth) )
            {
                $header_object->$meth->add( 'Set-Cookie' => $cookie );
                last;
            }
        }
    }

    # always set this even if we skipped actually setting the cookie
    # to avoid resending it.  this keeps us from entering this method
    # over and over
    $self->{cookie_is_baked} = 1
        unless $self->{cookie_resend};
}

sub session
{
    my $self = shift;
    my %p = validate( @_,
		      { session_id =>
			{ type => SCALAR,
                          optional => 1,
			},
		      } );

    if ( ! $self->{session} || %p )
    {
        $self->_make_session( $p{session_id} );

        $self->_bake_cookie
            if $self->{use_cookie} && ! $self->{cookie_is_baked};
    }

    return $self->{session};
}

sub delete_session
{
    my $self = shift;

    return unless $self->{session};

    my $session = delete $self->{session};

    (tied %$session)->delete;

    delete $self->{session_id};

    $self->_bake_cookie('-1d') if $self->{use_cookie};
}

sub cleanup_session
{
    my $self = shift;

    if ( $self->{always_write} )
    {
	if ( $self->{session}->{___force_a_write___} )
	{
	    $self->{session}{___force_a_write___} = 0;
	}
	else
	{
	    $self->{session}{___force_a_write___} = 1;
	}
    }

    undef $self->{session};
}

sub DESTROY { $_[0]->cleanup_session }


1;

__END__