File Coverage

blib/lib/WWW/Session.pm

Criterion	Covered	Total	%
statement	174	197	88.3
branch	50	72	69.4
condition	22	32	68.7
subroutine	30	35	85.7
pod	17	17	100.0
total	293	353	83.0

package WWW::Session;

use 5.006;
use strict;
use warnings;

=head1 NAME

WWW::Session - Generic session management engine for web applications

=head1 DESCRIPTION

Generic session management engine for web applications with multiple backends,
object serialization and data validation

=head1 VERSION

Version 0.12

=cut

our $VERSION = '0.12';

=head1 SYNOPSIS

This module allows you to easily create sessions , store data in them and later
retrieve that information, using multiple storage backends

Example:

    use WWW::Session;

    #set up the storage backends
    WWW::Session->add_storage( 'File', {path => '/tmp/sessions'} );
    WWW::Session->add_storage( 'Memcached', {servers => ['127.0.0.1:11211']} );

    #Set up the serialization engine (defaults to JSON)
    WWW::Session->serialization_engine('JSON');

    #Set up the default expiration time (in seconds or -1 for never)
    WWW::Session->default_expiration_time(3600);

    #Turn on autosave
    WWW::Session->autosave(1);

    #and than ...

    #Create a new session
    my $session = WWW::Session->new($sid,$hash_ref);
    ...
    $session->sid(); #returns $sid
    $session->data(); #returns $hash_ref

    #set the user
    $session->user($user);
    #retrieve the user
    my $user = $session->user();

    #returns undef if it doesn't exist or it's expired
    my $session = WWW::Session->find($sid);

    #returns the existing session if it exists, creates a new session if it doesn't
    my $session = WWW::Session->find_or_create($sid);

Using the session :

=over 4

=item * Settings values

There are two ways you can save a value on the session :

    $session->set('user',$user);

    or

    $session->user($user);

If the requested field ("user" in the example above) already exists it will be
assigned the new value, if it doesn't it will be added.

When you set a value for a field it will be validated first (see setup_field() ).
If the value doesn't pass validation the field will keep it's old value and the
set method will return 0. If everything goes well the set method will return 1.

=item * Retrieving values

    my $user = $session->get('user');

    or

    my $user = $session->user();

If the requested field ("user" in the example above) already exists it will return
it's value, otherwise will return C

=back

We can automaticaly deflate/inflate certain informations when we store / retrieve
from storage the session data (see setup_field() for more details):

    WWW::Session->setup_field( 'user',
                               inflate => sub { return Some::Package->new( $_[0] ) },
                               deflate => sub { $_[0]->id() }
                            );

We can automaticaly validate certain informations when we store / retrieve
from storage the session data (see setup_field() for more details):

    WWW::Session->setup_field( 'age',
                               filter => sub { $_[0] >= 18 }
                             );


Another way to initialize the module :

    use WWW::Session storage => [ 'File' => { path => '/tmp/sessions'},
                                  'Memcached' => { servers => ['127.0.0.1'] }
                                ],
                     serialization => 'JSON',
                     expires => 3600,
                     fields => {
                               user => {
                                     inflate => sub { return Some::Package->new( $_[0] ) },
                                     deflate => sub { $_[0]->id() },
                                     }
                               };

=cut

#Internal variables
my @storage_engines = ();
my $serializer = undef;
my $default_expiration = -1;
my $fields_modifiers = {};
my $autosave = 1;

#Set up the default serializer
__PACKAGE__->serialization_engine('JSON');

=head1 SESSION & OBJECTS

The default serialization engine is JSON, but JSON can't serialize objects by default,
you will have to write more code to accomplish that. If your session data data contains
objects you can take one of the following approaches :

=over 4

=item * Use inflate/deflate (recommended)

    # if we have a user object (eg MyApp::User) we can deflate it like this

    WWW::Session->setup_field('user', deflate => sub { return $_[0]->id() } );

    #and inflate it back like this

    WWW::Session->setup_field('user',inflate => sub { return Some::Package->new( $_[0] ) } );

This method even thow it's slower, it reduces the size of the session object when stored, and
it ensures that if the object data changed since we saved it, this changes will be reflected in the
object when we retrieve restore it (usefull for database result objects)

=item * Change the serialization module to 'Storable'

The 'Storable' serialization engine can handle object without any additional changes

    WWW::Session->serialization_engine('Storable');

Note : The perl Storable module is not very compatible between different version, so sharing data
between multiple machines could cause problems. We recommad using the 'JSON' engine with
inflate/defate (described above);

=back

=head1 STORAGE BACKENDS

You can use one or more of the fallowing backends (the list might not be complete, more backends might be available on CPAN):

=head2 File storage

Here is how you can set up the File storage backend :

    use WWW::Session;

    WWW::Session->add_storage('File', {path => '.'} );

See WWW::Session::Storage::File for more details

=head2 Database storage

If you want to store your session is MySQL do this :

    use WWW::Session;

    WWW::Session->add_storage( 'MySQL', {
                                            dbh => $dbh,
                                            table => 'sessions',
                                            fields => {
                                                    sid => 'session_id',
                                                    expires => 'expires',
                                                    data => 'data'
                                            },
                                        }
                              );

The "fields" hasref contains the mapping of session internal data to the column names from MySQL.
The keys are the session fields ("sid","expires" and "data") and must all be present.

The MySQL types of the columns should be :

=over 4

=item * sid => varchar(32)

=item * expires => DATETIME or TIMESTAMP

=item * data => text

=back

See WWW::Session::Storage::MySQL for more details

=head2 Memcached storage

    To use memcached as a storage backend do this :

    use WWW::Session;

    WWW::Session->add_storage('Memcached', {servers => ['127.0.0.1:11211']} );


See WWW::Session::Storage::Memcached for more details


=head1 SUBROUTINES/METHODS

=head2 new

Creates a new session object with the unique identifier and the given data.
If a session with the same identifier previously existed it will be overwritten

Parameters

=over 4

=item * sid = unique id for this session

=item * data = hash reference containing the data that we want to store in the session object

=item * exipres = for how many secconds is this session valid (defaults to the default expiration time)

=back

Retuns a WWW::Session object

Usage :

    my $session = WWW::Session->new('session_id',{ a=> 1, b=> 2});

=cut

sub new {
    my ($class,$sid,$data,$expires) = @_;

    $expires ||= -1;
    $data ||= {};

    die "You cannot use a undefined string as a session id!" unless $sid;

    my $self = {
                data    => {},
                expires => $expires,
                sid     => $sid,
                changed => {},
               };

    bless $self, $class;

    $self->set($_,$data->{$_}) foreach keys %{$data};

    return $self;
}

=head2 find

Retieves the session object for the given session id

Usage :

    my $session = WWW::Session->find('session_id');

=cut
sub find {
    my ($class,$sid) = @_;

    die "You cannot use a undefined string as a session id!" unless $sid;

    my $info;

    foreach my $storage (@storage_engines) {
        $info = $storage->retrieve($sid);
        last if defined $info;
    }

    if ($info) {
        my $session = $class->load($info);
        $session->{changed} = {};
        return $session;
    }

    return undef;
}

=head2 find_or_create

Retieves the session object for the given session id if it exists, if not it
creates a new object with the given session id

=over 4

=item * sid = unique id for this session

=item * data = hash reference containing the data that we want to store in the session object

=item * exipres = for how many secconds is this session valid (defaults to the default expiration time),

=back

Usage:

    my $session = WWW::Session->find_or_create('session_id',{ c=>2 })

=cut
sub find_or_create {
    my ($class,$sid,$data,$expires) = @_;

    my $self = $class->find($sid);

    if ($self) {
        $self->expires($expires) if defined ($expires);
        $self->set($_,$data->{$_}) foreach keys %{$data};
    }
    else {
        $self = $class->new($sid,$data,$expires);
    }

    return $self;
}


=head2 set

Adds/sets a new value for the given field

Usage :

    $session->set('user',$user);

The values can also be set by calling the name of the field you want to set
as a method :

    $session->user($user);

=cut

sub set {
    my ($self,$field,$value) = @_;

    if (! defined $value && exists $fields_modifiers->{$field} && defined $fields_modifiers->{$field}->{default}) {
        $value = $fields_modifiers->{$field}->{default};
    }

    $self->run_trigger('before_set_value',$field,$value,$self->get($field));

    my $validated = 1;

    if ( exists $fields_modifiers->{$field} && defined $fields_modifiers->{$field}->{filter} ) {

        $validated = 0; #we have a filter, check the value against the filter first

        my $filter = $fields_modifiers->{$field}->{filter};

        die "Filter must be a hash ref or array ref or code ref" unless ref($filter);

        if (ref($filter) eq "ARRAY") {
            if (grep { $value eq $_ } @{$filter}) {
                $validated = 1;
            }
        }
        elsif (ref($filter) eq "CODE") {
            $validated = $filter->($value);
        }
        elsif (ref($filter) eq "HASH") {
            my $h_valid = 1;

            if ( defined $filter->{isa} ) {
                $h_valid = 0 unless ref($value) eq $filter->{isa};
            }

            $validated = $h_valid;
        }
    }

    if ($validated) {
        $self->{data}->{$field} = $value;
        $self->{changed}->{$field} = 1;

        $self->run_trigger('after_set_value',$field,$value);
    }
    else {
        warn "Value $value failed validation for key $field";
    }

    return $validated;
}


=head2 get

Retrieves the value of the given key from the session object

Usage :

    my $user = $session->get('user');

You can also use the name of the field you want to retrieve as a method.
The above call does the same as :

    my $user = $session->user();

=cut

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

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

=head2 delete

Removes the given key from the session data

Usage :

    $session->delete('user');

=cut
sub delete {
    my ($self,$field) = @_;

    $self->run_trigger('before_delete',$field,$self->get($field));

    $self->{changed}->{$field} = 1;
    my $rv = delete $self->{data}->{$field};

    $self->run_trigger('after_delete',$field,$self->get($field));

    return $rv;
}

=head2 sid

Returns the session id associated with this session

=cut

sub sid {
    my ($self) = @_;

    return $self->{sid};
}

=head2 expires

Getter/Setter for the expiration time of this session

=cut

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

    if (defined $value) {
        $self->{expires} = $value;
    }

    return $self->{expires};
}

=head2 add_storage

Adds a new storge engine to the list of Storage engines that will be used to
store the session info

Usage :

    WWW::Session->add_storage($storage_engine_name,$storage_engine_options);

Parameters :

=over 4

=item * $storage_engine_name = Name of the class that defines a valid storage engine

For WWW::Session::Storage::* modules you can use only the name of the storage,
you don't need the full name. eg Memcached and WWW::Session::Storage::Memcached
are synonyms

=item * $storage_engine_options = hash ref containing the options that will be
passed on to the storage engine module when new() is called

=back

Example :

    WWW::Session->add_storage( 'File', {path => '/tmp/sessions'} );

    WWW::Session->add_storage( 'Memcached', {servers => ['127.0.0.1:11211']} );

See each storage module for aditional details

=cut

sub add_storage {
    my ($class,$name,$options) = @_;

    $options ||= {};

    if ($name !~ /::/) {
        $name = "WWW::Session::Storage::$name";
    }

    eval "use $name";

    die "WWW::Session cannot load '$name' storage engine! Error : $@" if ($@);

    my $storage = $name->new($options);

    if ($storage) {
        push @storage_engines, $storage;
    }
    else {
        die "WWW::Session storage engine '$name' failed to initialize with the given arguments!";
    }
}

=head2 serialization_engine

Configures the serialization engine to be used for serialising sessions.

The default serialization engine is JSON

Usage :

    WWW::Session->serialization_engine('JSON');

Parameters :

=over 4

=item * $serialization_engine_name = Name of the class that defines a valid serialization engine

For WWW::Session::Serialization::* modules you can use only the short name of the module,
you don't need the full name. eg JSON and WWW::Session::Serialization::JSON
are synonyms

=back

=cut

sub serialization_engine {
    my ($class,$name) = @_;

    if ($name !~ /::/) {
        $name = "WWW::Session::Serialization::$name";
    }

    eval "use $name";

    die "WWW::Session cannot load '$name' serialization engine! Error : $@" if ($@);

    my $serializer_object = $name->new($fields_modifiers);

    if ($serializer_object) {
        $serializer = $serializer_object;
    }
    else {
        die "WWW::Session serialization engine '$name' failed to initialize!";
    }
}

=head2 autosave

Turn on/off the autosave feature (on by default)

If this feature is on the object will always be saved before beying destroyed

Usage :

    WWW::Session->autosave(1);

=cut

sub autosave {
    my ($class,$value) = @_;

    $autosave = $value if defined $value;

    return $autosave;
}

=head2 default_expiration_time

Setter/Getter for the default expiration time

Usage :

    WWW::Session->default_expiration_time(1800);

=cut

sub default_expiration_time {
    my ($class,$value) = @_;

    if (defined $value) {
        $default_expiration = $value;
    }

    return $default_expiration;
}

=head2 destroy

Completely removes all the data related to the current session

NOTE: After calling destroy the session object will no longer be usable

Usage :

    $session->destroy();

=cut

sub destroy {

    #save the session id fiers and undef the object before we delete it from
    #storage to avoid autosave kikking in after we remove it from storage

    my $sid = $_[0]->sid();

    $_[0] = undef;

    foreach my $storage (@storage_engines) {
        $storage->delete($sid);
    }
}


=head2 setup_field

Sets up the filters, inflators and deflators for the given field

=head3 deflators

Deflators are passed as code refs. The only argument the deflator
method receives is the value of the filed that it must be deflated and
it must return a single value (scalar, object or reference) that will be
asigned to the key.

Example :

    # if we have a user object (eg MyApp::User) we can deflate it like this

    WWW::Session->setup_field('user', deflate => sub { return $_[0]->id() } );

=head3 inflators

Inflators are passed as code refs. The only argument the inflator
method receives is the value of the filed that it must inflate and
it must return a single value (scalar, object or reference) that will be
asigned to the key.

Example :

    # if we have a user object (eg MyApp::User) we can inflate it like this

    WWW::Session->setup_field('user',inflate => sub { return Some::Package->new( $_[0] ) } );

=head3 filters

Filters can be used to ensure that the values from the session have the required values

Filters can be :

=over 4

=item * array ref

In this case when we call $session->set($field,$value) the values will have to be one of the
values from the array ref , or the operation will fail

Example :

    #Check that the age is between 18 and 99
    WWW::Session->setup_field('age',filter => [18..99] );

=item * code ref

In this case the field value will be passed to the code ref as the only parameter. The code ref
must return a true or false value. If it returns a false value the set() operation will fail

Example :

    #Check that the age is > 18
    WWW::Session->setup_field('age',filter => sub { $_[0] > 18 } );

=item * hash ref

In this case the only key from the hash that is recognised is "isa" will will chek that the
given value has the types specified as the value for "isa"

Example :

    #Check that the 'rights' field is an array
    WWW::Session->setup_field('age',filter => { isa => "ARRAY" } );

    #Check that the 'user' field is an MyApp::User object
    WWW::Session->setup_field('user',filter => { isa => "MyApp::User" } );

=back

=head3 triggers

Triggers allow you to execute a code ref when certain events happen on the key.

The return values from the triggers are completely ignored.

Available triggers are:

=over 4

=item * before_set_value

Executed before the value is actually storred on the code. Arguments sent to the code ref
are : session object , new value, old value - in this order

=item * after_set_value

Executed after the new value is set on the session object. Arguments sent to the code ref
are : session object, new value

=item * before_delete

Executed before the key is removed from the session object. Arguments sent to the code ref
are : session object, current_value

=item * after_delete

Executed after the key is removed from the session object. Arguments sent to the code ref
are : session object, previous_value

=back

Example :

    WWW::Session->setup_field(
                            'user',
                            filter => { isa => "MyApp::User" },
                            deflate => sub { $_[0]->id() },
                            inflate => sub { return MyApp::User->find($_[0]) }
                            trigger => { before_set_value => sub { warn "About to set the user },
                                         after_delete => sub { ... },
                                        }
                            );

=cut

sub setup_field {
    my ($self,$field,%settings) = @_;

    while (my ($key,$val)  = each %settings) {
        $fields_modifiers->{$field}{$key} = $val;
    }
}

=head2 save

Serializes a WWW::Session object sends it to all storage engines for saving

=cut

sub save {
    my ($self) = @_;

    my $data = {
                sid => $self->{sid},
                expires => $self->{expires},
               };

    foreach my $field ( keys %{$self->{data}} ) {
        if (defined $fields_modifiers->{$field} && defined $fields_modifiers->{$field}->{deflate}) {
            $data->{data}->{$field} = $fields_modifiers->{$field}->{deflate}->($self->{data}->{$field});
        }
        else {
            $data->{data}->{$field} = $self->{data}->{$field}
        }
    }

    my $string = $serializer->serialize($data);

    foreach my $storage (@storage_engines) {
        $storage->save($self->{sid},$self->{expires},$string);
    }
}

=head1 ACCESSING SESSION DATA

Allows us to get/set session data directly by calling the field name as a method

Example:

    my $user = $session->user(); #same as $user = $session->get('user');

    #or

    $session->age(21); #same as $session->set('age',21);

=cut

our $AUTOLOAD;
sub AUTOLOAD {
    my $self = shift;
    my $value = shift;

    my $field = $AUTOLOAD;

    $field =~ s/.*:://;

    if (defined $value) {
        $self->set($field,$value);
    }

    return $self->get($field);
}


=head1 AUTOSAVE FEATURE

If you set autosave to 1 the session will be saved before the object is
destroyed if any data has changed

BE CAREFULL : If you store complex structures only the changes made to direct
session keys will be detected.

Example :

    #this change will be detected because it affects a direct session attribute
    $session->age(21);

    #this changes won't be detected :
    my $user = $session->user();
    $user->{age} = 21;

You have two choices :

=over 4

=item 1 Make a change that can be detected

    $session->some_random_field( time() );

=item 2 Save the session manually

    $session->save();

=back

=cut

sub DESTROY {
    my $self = shift;

    if ($autosave && scalar(keys %{$self->{changed}})) {
        $self->save();
    }
}


=head1 PRIVATE METHODS

=head2 load

Deserializes a WWW::Session object from the given string and deflates all the fields that
were inflated when the session was serialized

=cut

sub load {
    my ($class,$string) = @_;

    my $self = $serializer->expand($string);

    foreach my $field ( keys %{$self->{data}} ) {
        if (defined $fields_modifiers->{$field} && defined $fields_modifiers->{$field}->{inflate}) {
            $self->{data}->{$field} = $fields_modifiers->{$field}->{inflate}->($self->{data}->{$field});
        }
    }

    bless $self,$class;

    return $self;
}

=head2 import

Allows us to configure all the module options in one line

Example :

    use WWW::Session storage => [
                                    'File' => { path => '/tmp/sessions'},
                                    'Memcached' => { servers => ['127.0.0.1'] }
                                ],
                     serialization => 'Storable',
                     expires => 3600,
                     fields => {
                         user => {
                             inflate => sub { return Some::Package->new( $_[0]->id() ) },
                             deflate => sub { $_[0]->id() },
                             },
                         age => {
                             filter => [21..99],
                             }
                     },
                     autosave => 1;

=cut

sub import {
    my ($class, %params) = @_;

    if (defined $params{storage}) {
        while ( scalar(@{$params{storage}}) ) {
            my $engine = shift @{$params{storage}};
            my $options = shift @{$params{storage}};
            $class->add_storage($engine,$options);
        }
    }
    if (defined $params{serialization}) {
        $class->serialization_engine($params{serialization});
    }
    if (defined $params{expires}) {
        $class->default_expiration_time($params{expires});
    }
    if (defined $params{autosave}) {
        $class->autosave($params{autosave});
    }
    if (defined $params{fields}) {
        foreach my $field (keys %{$params{fields}}) {
            $class->setup_field($field,%{ $params{fields}->{$field} });
        }
    }
}

=head2 run_trigger

Runs a trigger for the given field

=cut
sub run_trigger {
    my $self = shift;
    my $trigger = shift;
    my $field = shift;

    if (   exists $fields_modifiers->{$field}
        && defined $fields_modifiers->{$field}{trigger}
        && defined $fields_modifiers->{$field}{trigger}{$trigger} )
    {
        my $trigger = $fields_modifiers->{$field}{trigger}{$trigger};
        die "WWW::Session triggers must be code refs!" unless ref( $trigger ) && ref( $trigger ) eq "CODE";
        $trigger->( $self, @_ );
    }
}


=head1 TIE INTERFACE

The WWW::Session objects can be tied to hashes to make them easier to use

Example :

    my %session;

    tie %session, WWW::Session, 'session_id', {user => $user, authenticated => 1};

    ...
    my $user = $session{user};

    ...
    $session{authenticated} = 0;
    delete $session{user};

=cut

sub TIEHASH {
    my ($class,@params) = @_;

    return $class->find_or_create(@params);
}

sub STORE {
    my ($self,$key,$value) = @_;

    $self->set($key,$value);
}

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

    return $self->get($key);
}

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

    $self->delete($key);
}

sub CLEAR {
    my ($self) = @_;

    $self->{data} = {};
}

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

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

sub FIRSTKEY {
    my ($self) = @_;

    my $a = keys %{ $self->{data} };

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

sub NEXTKEY {
    my ($self) = @_;

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

sub SCALAR {
    my ($self) = @_;

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

=head1 AUTHOR

Gligan Calin Horea, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc WWW::Session


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2012 Gligan Calin Horea.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of WWW::Session