FastMmap.pm

   1 package Catalyst::Plugin::Session::FastMmap;
   2
   3 use strict;
   4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
   5 use NEXT;
   6 use Cache::FastMmap;
   7 use Digest::MD5;
   8 use URI;
   9 use URI::Find;
  10 use File::Temp 'tempdir';
  11
  12 our $VERSION = '0.07';
  13
  14 __PACKAGE__->mk_classdata('_session');
  15 __PACKAGE__->mk_accessors('sessionid');
  16
  17 =head1 NAME
  18
  19 Catalyst::Plugin::Session::FastMmap - FastMmap sessions for Catalyst
  20
  21 =head1 SYNOPSIS
  22
  23     use Catalyst 'Session::FastMmap';
  24
  25     $c->session->{foo} = 'bar';
  26     print $c->sessionid;
  27
  28 =head1 DESCRIPTION
  29
  30 Fast sessions.
  31
  32 =head2 EXTENDED METHODS
  33
  34 =head3 finalize
  35
  36 =cut
  37
  38 sub finalize {
  39     my $c        = shift;
  40     unless ($c->config->{no_url_rewrite}) {
  41         my $redirect = $c->response->redirect;
  42         $c->response->redirect( $c->uri($redirect) ) if $redirect;
  43     }
  44     if ( my $sid = $c->sessionid ) {
  45         $c->_session->set( $sid, $c->session );
  46         my $set = 1;
  47         if ( my $cookie = $c->request->cookies->{session} ) {
  48             $set = 0 if $cookie->value eq $sid;
  49         }
  50         $c->response->cookies->{session} = { value => $sid } if $set;
  51         unless ($c->config->{no_url_rewrite}) {
  52           my $finder = URI::Find->new(
  53               sub {
  54                   my ( $uri, $orig ) = @_;
  55                   my $base = $c->request->base;
  56                   return $orig unless $orig =~ /^$base/;
  57                   return $orig if $uri->path =~ /\/-\//;
  58                   return $c->uri($orig);
  59              }
  60           );
  61           $finder->find( \$c->res->{output} ) if $c->res->output;
  62         }
  63     }
  64     return $c->NEXT::finalize(@_);
  65 }
  66
  67 =head3 prepare_action
  68
  69 =cut
  70
  71 sub prepare_action {
  72     my $c = shift;
  73     if ( $c->request->path =~ /^(.*)\/\-\/(.+)$/ ) {
  74         $c->request->path($1);
  75         $c->sessionid($2);
  76         $c->log->debug(qq/Found sessionid "$2" in path/) if $c->debug;
  77     }
  78     if ( my $cookie = $c->request->cookies->{session} ) {
  79         my $sid = $cookie->value;
  80         $c->sessionid($sid);
  81         $c->log->debug(qq/Found sessionid "$sid" in cookie/) if $c->debug;
  82     }
  83     $c->NEXT::prepare_action(@_);
  84 }
  85
  86 sub session {
  87     my $c = shift;
  88     return $c->{session} if $c->{session};
  89     my $sid = $c->sessionid;
  90     if (   $sid
  91         && $c->_session
  92         && ( $c->{session} = $c->_session->get($sid) ) )
  93     {
  94         $c->log->debug(qq/Found session "$sid"/) if $c->debug;
  95         return $c->{session};
  96     }
  97     else {
  98         my $sid = Digest::MD5::md5_hex( time, rand, $$, 'catalyst' );
  99         $c->sessionid($sid);
 100         $c->log->debug(qq/Created session "$sid"/) if $c->debug;
 101         return $c->{session} = {};
 102     }
 103 }
 104
 105 =head3 setup
 106
 107 =cut
 108
 109 sub setup {
 110     my $self               = shift;
 111     my $cache_root         = $self->config->{cache_root} || tempdir;
 112     my $default_expires_in = $self->config->{default_expires_in}
 113       || 60 * 60 * 24;
 114     my $auto_purge_interval = $self->config->{auto_purge_interval}
 115       || 60 * 60 * 24;
 116     my $auto_purge_on_set = $self->config->{auto_purge_on_set} || 1;
 117     $self->_session(
 118         Cache::FastMmap->new(
 119             cache_root          => $cache_root,
 120             default_expires_in  => $default_expires_in,
 121             auto_purge_interval => $auto_purge_interval,
 122             auto_purge_on_set   => $auto_purge_on_set
 123         )
 124     );
 125     return $self->NEXT::setup(@_);
 126 }
 127
 128 =head2 METHODS
 129
 130 =head3 session
 131
 132 =head3 uri
 133
 134 Extends an uri with session id if needed.
 135
 136     my $uri = $c->uri('http://localhost/foo');
 137
 138 =cut
 139
 140 sub uri {
 141     my ( $c, $uri ) = @_;
 142     if ( my $sid = $c->sessionid ) {
 143         $uri = URI->new($uri);
 144         my $path = $uri->path;
 145         $path .= '/' unless $path =~ /\/$/;
 146         $uri->path( $path . "-/$sid" );
 147         return $uri->as_string;
 148     }
 149     return $uri;
 150 }
 151
 152 =head2 CONFIG OPTIONS
 153
 154 =head3 no_url_rewrite
 155
 156 To disable automatic storing of sessions in the url,
 157 you can disable the url rewriting for session by setting
 158 this to a true value.
 159
 160 =head3 cache_root
 161
 162 The root directory for the session cache. defaults to a
 163 tempdir.
 164
 165 =head3 default_expires_in
 166
 167 how many seconds until the session expires. defaults to 1 day
 168
 169 =head3 auto_purge_interval
 170
 171 How often should the system purge sessions. Defaults to 1 time
 172 per day.
 173
 174 =head3 auto_purge_on_set
 175
 176 Is auto purge enabled? defaults to true.
 177
 178 =head1 SEE ALSO
 179
 180 L<Catalyst> L<Cache::FastMmap>.
 181
 182 =head1 AUTHOR
 183
 184 Sebastian Riedel, C<sri@cpan.org>
 185 Marcus Ramberg C<mramberg@cpan.org>
 186
 187 =head1 COPYRIGHT
 188
 189 This program is free software, you can redistribute it and/or modify it under
 190 the same terms as Perl itself.
 191
 192 =cut
 193
 194 1;