MasonX::Request::WithMultiSession2 - Multiple sub-sessions within one "parent" session

  PerlSetVar  MasonRequestClass  MasonX::Request::WithMultiSession2

package MasonX::Request::WithMultiSession2;

use strict;

use Digest::SHA1 ();
use Time::HiRes;

use base qw(MasonX::Request::WithApacheSession2);

use HTML::Mason::Exceptions ( abbr => [ qw( param_error error ) ] );

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

__PACKAGE__->valid_params
    ( multi_session_args_param =>
      { type => SCALAR,
        default => 'sub_session_id',
        descr => 'The parameter name which contains the sub-session id',
      },

      multi_session_expire =>
      { type    => Params::Validate::SCALAR,
        default => undef,
        descr => 'How long a sub-session stays valid',
      },
    );

sub session
{
    my $self = shift;

    return $self->parent_request->session(@_) if $self->is_subrequest;

    my %p = @_;

    my %super_p = exists $p{session_id} ? ( session_id => $p{session_id} ) : ();
    my $session = $self->SUPER::session(%super_p);

    my %sub_session_p =
        exists $p{sub_session_id} ? ( sub_session_id => $p{sub_session_id} ) : ();
    my $id = $self->sub_session_id(%sub_session_p);

    if ( $p{clone} || $p{new} )
    {
        # forces creation of a new id
        delete $self->{sub_session_id};
        my $new_id = $self->_make_new_sub_session_id;

        if ( $p{clone} )
        {
            # shallow copy of old session
            $session->{sub_sessions}{$new_id} = { %{ $session->{sub_sessions}{$id} } };
        }

        $id = $new_id;
    }

    $session->{sub_session_ids}{$id} = int(time);

    return $session->{sub_sessions}{$id};
}

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

    unless ( exists $self->{sub_session_id} )
    {
        my $args = $self->request_args;

        my $args_key = $self->{multi_session_args_param};

        my $session = $self->SUPER::session;
        if ( exists  $p{sub_session_id} )
        {
            unless ( exists $session->{sub_session_ids}{ $p{sub_session_id} } )
            {
                $session->{sub_sessions}{ $p{sub_session_id} } = {};
            }

            $self->{sub_session_id} = $p{sub_session_id};
        }
        elsif ( exists $args->{$args_key} &&
                exists $session->{sub_session_ids}{ $args->{$args_key} } )
        {
            $self->{sub_session_id} = $args->{$args_key};
        }
        else
        {
            $self->_make_new_sub_session_id;
        }
    }

    return $self->{sub_session_id};
}

sub _make_new_sub_session_id
{
    my $self = shift;

    my $session = $self->SUPER::session;

    my $new_id;

    do
    {
        # using Time::HiRes means that we get times with very high
        # floating point resolutions (to 10 or 11 decimal places), so
        # this is a good seed for a hashing algorithm
        $new_id = Digest::SHA1::sha1_hex( time() . {} . rand() . $$ );
    } while ( exists $session->{sub_session_ids}{$new_id} );

    $session->{sub_sessions}{$new_id} = {};

    $self->{sub_session_id} = $new_id;

    return $new_id;
}

sub delete_sub_session
{
    my $self = shift;

    my $session = $self->SUPER::session;

    my %p = validate( @_,
		      { sub_session_id =>
			{ type => SCALAR,
                          optional => 1,
			},
		      } );

    my $sub_id = $p{sub_session_id} ? $p{sub_session_id} : delete $self->{sub_session_id};

    delete $session->{sub_sessions}{$sub_id};
    delete $session->{sub_session_ids}{$sub_id};
}

sub delete_session
{
    my $self = shift;

    $self->SUPER::delete_session;

    delete $self->{sub_session_id};
}

sub DESTROY
{
    my $self = shift;

    return unless defined $self->{multi_session_expire};

    my $session = $self->SUPER::session;

    my $cutoff = int(time) - $self->{multi_session_expire};
    foreach my $id ( keys %{ $session->{sub_session_ids} } )
    {
        if ( $session->{sub_session_ids}{$id} < $cutoff )
        {
            delete $session->{sub_sessions}{$id};
            delete $session->{sub_session_ids}{$id};
        }
    }
}


1;

__END__