File Coverage

blib/lib/CGI/Application/Plugin/Session.pm

Criterion	Covered	Total	%
statement	90	134	67.1
branch	55	78	70.5
condition	20	49	40.8
subroutine	13	16	81.2
pod	6	6	100.0
total	184	283	65.0

package CGI::Application::Plugin::Session;
{
  $CGI::Application::Plugin::Session::VERSION = '1.05';
}

use CGI::Session ();
use File::Spec ();
use CGI::Application 3.21;
use Carp qw(croak);
use Scalar::Util ();

# ABSTRACT: Plugin that adds session support to CGI::Application

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

require Exporter;

@EXPORT = qw(
  session
  session_config
  session_cookie
  session_delete
  session_loaded
  session_recreate
);
sub import { goto &Exporter::import }

sub session {
    my $self = shift;

    if (!$self->{__CAP__SESSION_OBJ}) {
        # define the config hash if it doesn't exist to save some checks later
        $self->{__CAP__SESSION_CONFIG} = {} unless $self->{__CAP__SESSION_CONFIG};

        # gather parameters for the CGI::Session module from the user,
        #  or use some sane defaults
        my @params = ($self->{__CAP__SESSION_CONFIG}->{CGI_SESSION_OPTIONS}) ?
                        @{ $self->{__CAP__SESSION_CONFIG}->{CGI_SESSION_OPTIONS} } :
                        ('driver:File', $self->query, {Directory=>File::Spec->tmpdir});


        # CGI::Session only works properly with CGI.pm so extract the sid manually if
        # another module is being used
        if (Scalar::Util::blessed($params[1]) && ! $params[1]->isa('CGI')) {
            my $name = __locate_session_name( $self ); ## plugin method call
+           my $sid  = $params[1]->cookie($name) || $params[1]->param($name);
            $params[1] = $sid;
        }

        # create CGI::Session object or die with an error
        $self->{__CAP__SESSION_OBJ} = CGI::Session->new(@params);
        if (! $self->{__CAP__SESSION_OBJ} ) {
            my $errstr = CGI::Session->errstr || 'Unknown';
            croak "Failed to Create CGI::Session object :: Reason: $errstr";
        }

        # Set the default expiry if requested and if this is a new session
        if ($self->{__CAP__SESSION_CONFIG}->{DEFAULT_EXPIRY} && $self->{__CAP__SESSION_OBJ}->is_new) {
            $self->{__CAP__SESSION_OBJ}->expire($self->{__CAP__SESSION_CONFIG}->{DEFAULT_EXPIRY});
        }

        # add the cookie to the outgoing headers under the following conditions
        #  if the cookie doesn't exist,
        #  or if the session ID doesn't match what is in the current cookie,
        #  or if the session has an expiry set on it
        #  but don't send it if SEND_COOKIE is set to 0
        if (!defined $self->{__CAP__SESSION_CONFIG}->{SEND_COOKIE} || $self->{__CAP__SESSION_CONFIG}->{SEND_COOKIE}) {
            my $cid = $self->query->cookie(
                $self->{__CAP__SESSION_OBJ}->name
            );
            if (!$cid || $cid ne $self->{__CAP__SESSION_OBJ}->id || $self->{__CAP__SESSION_OBJ}->expire()) {
                session_cookie($self);
            }
        }
    }

    return $self->{__CAP__SESSION_OBJ};
}

sub session_config {
    my $self = shift;

    if (@_) {
      die "Calling session_config after the session has already been created" if (defined $self->{__CAP__SESSION_OBJ});
      my $props;
      if (ref($_[0]) eq 'HASH') {
          $props = $self->_cap_hash($_[0]);
      } else {
          $props = $self->_cap_hash({ @_ });
      }

      # Check for CGI_SESSION_OPTIONS
      if ($props->{CGI_SESSION_OPTIONS}) {
        die "session_config error:  parameter CGI_SESSION_OPTIONS is not an array reference" if ref $props->{CGI_SESSION_OPTIONS} ne 'ARRAY';
        $self->{__CAP__SESSION_CONFIG}->{CGI_SESSION_OPTIONS} = delete $props->{CGI_SESSION_OPTIONS};
      }

      # Check for COOKIE_PARAMS
      if ($props->{COOKIE_PARAMS}) {
        die "session_config error:  parameter COOKIE_PARAMS is not a hash reference" if ref $props->{COOKIE_PARAMS} ne 'HASH';
        $self->{__CAP__SESSION_CONFIG}->{COOKIE_PARAMS} = delete $props->{COOKIE_PARAMS};
      }

      # Check for SEND_COOKIE
      if (defined $props->{SEND_COOKIE}) {
        $self->{__CAP__SESSION_CONFIG}->{SEND_COOKIE} = (delete $props->{SEND_COOKIE}) ? 1 : 0;
      }

      # Check for DEFAULT_EXPIRY
      if (defined $props->{DEFAULT_EXPIRY}) {
        $self->{__CAP__SESSION_CONFIG}->{DEFAULT_EXPIRY} = delete $props->{DEFAULT_EXPIRY};
      }

      # If there are still entries left in $props then they are invalid
      die "Invalid option(s) (".join(', ', keys %$props).") passed to session_config" if %$props;
    }

    $self->{__CAP__SESSION_CONFIG};
}

sub session_cookie {
    my $self = shift;
    my %options = @_;

    # merge in any parameters set by config_session
    if ($self->{__CAP__SESSION_CONFIG}->{COOKIE_PARAMS}) {
      %options = (%{ $self->{__CAP__SESSION_CONFIG}->{COOKIE_PARAMS} }, %options);
    }

    if (!$self->{__CAP__SESSION_OBJ}) {
        # The session object has not been created yet, so make sure we at least call it once
        my $tmp = $self->session;
    }

    ## check cookie option -name with session name
    ## if different these may cause problems/confusion
    if ( exists $options{'-name'} and
        $options{'-name'} ne $self->session->name ) {
        warn sprintf( "Cookie '%s' and Session '%s' name don't match.\n",
            $options{'-name'}, $self->session->name )
    }

    ## setup the values for cookie
    $options{'-name'}    ||= $self->session->name;
    $options{'-value'}   ||= $self->session->id;
    if(defined($self->session->expires()) && !defined($options{'-expires'})) {
        $options{'-expires'} = _build_exp_time( $self->session->expires() );
    }
    my $cookie = $self->query->cookie(%options);

    # Look for a cookie header in the existing headers
    my %headers = $self->header_props;
    my $cookie_set = 0;
    if (my $cookies = $headers{'-cookie'}) {
        if (ref($cookies) eq 'ARRAY') {
            # multiple cookie headers so check them all
            for (my $i=0; $i < @$cookies; $i++) {
                # replace the cookie inline if we find a match
                if (substr($cookies->[$i], 0, length($options{'-name'})) eq $options{'-name'}) {
                    $cookies->[$i] = $cookie;
                    $cookie_set++;
                }
            }
        } elsif (substr($cookies, 0, length($options{'-name'})) eq $options{'-name'}) {
            # only one cookie and it is ours, so overwrite it
            $self->header_add(-cookie => $cookie);
            $cookie_set++;
        }
    }

    $self->header_add(-cookie => [$cookie]) unless $cookie_set;

    return 1;
}

sub _build_exp_time {
    my $secs_until_expiry = shift;
    return unless defined $secs_until_expiry;

    # Add a plus sign unless the number is negative
    my $prefix = ($secs_until_expiry >= 0) ? '+' : '';

    # Add an 's' for "seconds".
    return $prefix.$secs_until_expiry.'s';
}

sub session_delete {
    my $self = shift;

    if ( my $session = $self->session ) {
        $session->delete;
        $session->flush;
        if ( $self->{'__CAP__SESSION_CONFIG'}->{'SEND_COOKIE'} ) {
            my %options;
            if ( $self->{'__CAP__SESSION_CONFIG'}->{'COOKIE_PARAMS'} ) {
                %options = ( %{ $self->{'__CAP__SESSION_CONFIG'}->{'COOKIE_PARAMS'} }, %options );
            }
            $options{'name'} ||= $session->name;
            $options{'value'}    = '';
            $options{'-expires'} = '-1d';
            my $newcookie = $self->query->cookie(\%options);

            # See if a session cookie has already been set (this will happen if
            #  this is a new session).  We keep all existing cookies except the
            #  session cookie, which we replace with the timed out session
            #  cookie
            my @keep;
            my %headers = $self->header_props;
            my $cookies = $headers{'-cookie'} || [];
            $cookies = [$cookies] unless ref $cookies eq 'ARRAY';
            foreach my $cookie (@$cookies) {
                if ( ref($cookie) ne 'CGI::Cookie' || $cookie->name ne $session->name ) {
                    # keep this cookie
                    push @keep, $cookie;
                }
            }
            push @keep, $newcookie;

            # We have to set the cookies this way, because CGI::Application has
            #  an annoying interface to the headers (why can't we have
            #  'header_set as well as header_add?).  The first call replaces all
            #  cookie headers with the one new cookie header, and the next call
            #  adds in the rest of the cookies if there are any.
            $self->header_add( -cookie => shift @keep );
            $self->header_add( -cookie => \@keep ) if @keep;
        }
    }
}

sub session_loaded {
    my $self = shift;
    return defined $self->{__CAP__SESSION_OBJ};
}

sub session_recreate {
    my $self = shift;
    my $data = {};

    # Copy all values from existing session and delete it
    if (session_loaded($self)) {
        $data = $self->session->param_hashref;
        $self->session->delete;
        $self->session->flush;
        $self->{__CAP__SESSION_OBJ} = undef;

    }

    # create a new session and populate it
    #  (This should also send out a new cookie if so configured)
    my $session = $self->session;
    while(my($k,$v) = each %$data) {
        next if index($k, '_SESSION_') == 0;
        $session->param($k => $v);
    }
    $session->flush;

    return 1;
}

## all a hack to adjust for problems with cgi::session and
## it not playing with non-CGI.pm objects
sub __locate_session_name {
    my $self = shift;
    my $sess_opts = $self->{__CAP__SESSION_CONFIG}->{CGI_SESSION_OPTIONS};

    ## search for 'name' cgi session option
    if ( $sess_opts and $sess_opts->[4]
         and ref $sess_opts->[4] eq 'HASH'
         and exists $sess_opts->[4]->{name} ) {
        return $sess_opts->[4]->{name};
    }

    return CGI::Session->name;
}

1;

__END__