File Coverage

blib/lib/HTTP/Session.pm

Criterion	Covered	Total	%
statement	104	107	97.2
branch	24	28	85.7
condition	12	15	80.0
subroutine	24	27	88.8
pod	10	10	100.0
total	174	187	93.0

package HTTP::Session;
use strict;
use warnings;
use base qw/Class::Accessor::Fast/;
use 5.00800;
our $VERSION = '0.48';
use Carp ();
use Scalar::Util ();
use Module::Runtime ();

__PACKAGE__->mk_ro_accessors(qw/store request sid_length save_modified_session_only/);
__PACKAGE__->mk_accessors(qw/session_id _data is_changed is_fresh state/);

sub new {
    my $class = shift;
    my %args = ref($_[0]) ? %{$_[0]} : @_;
    # check required parameters
    for my $key (qw/store state request/) {
        Carp::croak "missing parameter $key" unless $args{$key};
    }
    # set default values
    $args{_data} ||= {};
    $args{save_modified_session_only} ||= 0;
    $args{is_changed} ||= 0;
    $args{is_fresh}   ||= 0;
    $args{sid_length} ||= 32;
    $args{id}         ||= 'HTTP::Session::ID::SHA1';
    my $self = bless {%args}, $class;
    $self->_load_session();
    Carp::croak "[BUG] we have bug" unless $self->{request};
    $self;
}

sub _load_session {
    my $self = shift;

    my $session_id = $self->state->get_session_id($self->request);
    if ( $session_id ) {
        my $data = $self->store->select($session_id);
        if ($data) {
            $self->session_id( $session_id );
            $self->_data($data);
        } else {
            if ($self->state->permissive) {
                $self->session_id( $session_id );
                $self->is_fresh(1);
            } else {
                # session was expired? or session fixation?
                # regen session id.
                $self->session_id( $self->_generate_session_id() );
                $self->is_fresh(1);
            }
        }
    } else {
        # no sid; generate it
        $self->session_id( $self->_generate_session_id() );
        $self->is_fresh(1);
    }
}

sub _generate_session_id {
    my $self = shift;
    Module::Runtime::require_module($self->{id}) or die $@;
    $self->{id}->generate_id($self->sid_length);
}

sub response_filter {
    my ($self, $response) = @_;
    Carp::croak "missing response" unless ref $response;

    $self->state->response_filter($self->session_id, $response);
}

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

    if ($self->is_fresh) {
        if ($self->is_changed || !$self->save_modified_session_only) {
            $self->store->insert( $self->session_id, $self->_data );
        }
    } else {
        if ($self->is_changed) {
            $self->store->update( $self->session_id, $self->_data );
        }
    }

    delete $self->{$_} for keys %$self;
    bless $self, 'HTTP::Session::Finalized';
}

sub DESTROY {
    my $self = shift;

    if ($self->{store}) {
        $self->finalize();
    } else {
        # this case happen at global destruction?
        Carp::carp "you should call HTTP::Session->finalize method manually";
    }
}

sub keys {
    my $self = shift;
    return keys %{ $self->_data };
}

sub get {
    my ($self, $key) = @_;
    $self->_data->{$key};
}

sub set {
    my ($self, $key, $val) = @_;
    $self->is_changed(1);
    $self->_data->{$key} = $val;
}

sub remove {
    my ( $self, $key ) = @_;
    $self->is_changed(1);
    delete $self->_data->{$key};
}

sub as_hashref {
    my $self = shift;
    return { %{ $self->_data } }; # shallow copy
}

sub expire {
    my $self = shift;
    $self->store->delete($self->session_id);

    # XXX tricky bit to unlock
    delete $self->{$_} for qw(is_fresh is_changed);
    $self->DESTROY;

    # rebless to null class
    bless $self, 'HTTP::Session::Expired';
}

sub regenerate_session_id {
    my ($self, $delete_old) = @_;
    $self->_data( { %{ $self->_data } } );

    if ($delete_old) {
        my $oldsid = $self->session_id;
        $self->store->delete($oldsid);
    }
    my $session_id = $self->_generate_session_id();
    $self->session_id( $session_id );
    $self->is_fresh(1);
}

BEGIN {
    no strict 'refs';
    for my $meth (qw/redirect_filter header_filter html_filter/) {
        *{__PACKAGE__ . '::' . $meth} = sub {
            my ($self, $stuff) = @_;
            if ($self->state->can($meth)) {
                $self->state->$meth($self->session_id, $stuff);
            } else {
                $stuff;
            }
        };
    }
}

package HTTP::Session::Finalized;
sub is_fresh { 0 }
sub AUTOLOAD { }

package HTTP::Session::Expired;
sub is_fresh { 0 }
sub AUTOLOAD { }

1;
__END__