lib/CPAN/lib/CGI/Session/Driver/file.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
permissions -rw-r--r--
RELEASE 4.2.0 freetown
     1 package CGI::Session::Driver::file;
     2 
     3 # $Id: file.pm 351 2006-11-24 14:16:50Z markstos $
     4 
     5 use strict;
     6 
     7 use Carp;
     8 use File::Spec;
     9 use Fcntl qw( :DEFAULT :flock :mode );
    10 use CGI::Session::Driver;
    11 use vars qw( $FileName $NoFlock $UMask $NO_FOLLOW );
    12 
    13 BEGIN {
    14     # keep historical behavior
    15 
    16     no strict 'refs';
    17     
    18     *FileName = \$CGI::Session::File::FileName;
    19 }
    20 
    21 @CGI::Session::Driver::file::ISA        = ( "CGI::Session::Driver" );
    22 $CGI::Session::Driver::file::VERSION    = "4.20";
    23 $FileName                               = "cgisess_%s";
    24 $NoFlock                                = 0;
    25 $UMask                                  = 0660;
    26 $NO_FOLLOW                              = eval { O_NOFOLLOW } || 0;
    27 
    28 sub init {
    29     my $self = shift;
    30     $self->{Directory} ||= File::Spec->tmpdir();
    31 
    32     unless ( -d $self->{Directory} ) {
    33         require File::Path;
    34         unless ( File::Path::mkpath($self->{Directory}) ) {
    35             return $self->set_error( "init(): couldn't create directory path: $!" );
    36         }
    37     }
    38     
    39     $self->{NoFlock} = $NoFlock unless exists $self->{NoFlock};
    40     $self->{UMask} = $UMask unless exists $self->{UMask};
    41     
    42     return 1;
    43 }
    44 
    45 sub _file {
    46     my ($self,$sid) = @_;
    47     return File::Spec->catfile($self->{Directory}, sprintf( $FileName, $sid ));
    48 }
    49 
    50 sub retrieve {
    51     my $self = shift;
    52     my ($sid) = @_;
    53 
    54     my $path = $self->_file($sid);
    55     
    56     return 0 unless -e $path;
    57 
    58     # make certain our filehandle goes away when we fall out of scope
    59     local *FH;
    60 
    61     if (-l $path) {
    62         unlink($path) or 
    63           return $self->set_error("retrieve(): '$path' appears to be a symlink and I couldn't remove it: $!");
    64         return 0; # we deleted this so we have no hope of getting back anything
    65     }
    66     sysopen(FH, $path, O_RDONLY | $NO_FOLLOW ) || return $self->set_error( "retrieve(): couldn't open '$path': $!" );
    67     
    68     $self->{NoFlock} || flock(FH, LOCK_SH) or return $self->set_error( "retrieve(): couldn't lock '$path': $!" );
    69 
    70     my $rv = "";
    71     while ( <FH> ) {
    72         $rv .= $_;
    73     }
    74     close(FH);
    75     return $rv;
    76 }
    77 
    78 
    79 
    80 sub store {
    81     my $self = shift;
    82     my ($sid, $datastr) = @_;
    83     
    84     my $path = $self->_file($sid);
    85     
    86     # make certain our filehandle goes away when we fall out of scope
    87     local *FH;
    88     
    89     my $mode = O_WRONLY|$NO_FOLLOW;
    90     
    91     # kill symlinks when we spot them
    92     if (-l $path) {
    93         unlink($path) or 
    94           return $self->set_error("store(): '$path' appears to be a symlink and I couldn't remove it: $!");
    95     }
    96     
    97     $mode = O_RDWR|O_CREAT|O_EXCL unless -e $path;
    98     
    99     sysopen(FH, $path, $mode, $self->{UMask}) or return $self->set_error( "store(): couldn't open '$path': $!" );
   100     
   101     # sanity check to make certain we're still ok
   102     if (-l $path) {
   103         return $self->set_error("store(): '$path' is a symlink, check for malicious processes");
   104     }
   105     
   106     # prevent race condition (RT#17949)
   107     $self->{NoFlock} || flock(FH, LOCK_EX)  or return $self->set_error( "store(): couldn't lock '$path': $!" );
   108     truncate(FH, 0)  or return $self->set_error( "store(): couldn't truncate '$path': $!" );
   109     
   110     print FH $datastr;
   111     close(FH)               or return $self->set_error( "store(): couldn't close '$path': $!" );
   112     return 1;
   113 }
   114 
   115 
   116 sub remove {
   117     my $self = shift;
   118     my ($sid) = @_;
   119 
   120     my $directory = $self->{Directory};
   121     my $file      = sprintf( $FileName, $sid );
   122     my $path      = File::Spec->catfile($directory, $file);
   123     unlink($path) or return $self->set_error( "remove(): couldn't unlink '$path': $!" );
   124     return 1;
   125 }
   126 
   127 
   128 sub traverse {
   129     my $self = shift;
   130     my ($coderef) = @_;
   131 
   132     unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) {
   133         croak "traverse(): usage error";
   134     }
   135 
   136     opendir( DIRHANDLE, $self->{Directory} ) 
   137         or return $self->set_error( "traverse(): couldn't open $self->{Directory}, " . $! );
   138 
   139     my $filename_pattern = $FileName;
   140     $filename_pattern =~ s/\./\\./g;
   141     $filename_pattern =~ s/\%s/(\.\+)/g;
   142     while ( my $filename = readdir(DIRHANDLE) ) {
   143         next if $filename =~ m/^\.\.?$/;
   144         my $full_path = File::Spec->catfile($self->{Directory}, $filename);
   145         my $mode = (stat($full_path))[2] 
   146             or return $self->set_error( "traverse(): stat failed for $full_path: " . $! );
   147         next if S_ISDIR($mode);
   148         if ( $filename =~ /^$filename_pattern$/ ) {
   149             $coderef->($1);
   150         }
   151     }
   152     closedir( DIRHANDLE );
   153     return 1;
   154 }
   155 
   156 
   157 sub DESTROY {
   158     my $self = shift;
   159 }
   160 
   161 1;
   162 
   163 __END__;
   164 
   165 =pod
   166 
   167 =head1 NAME
   168 
   169 CGI::Session::Driver::file - Default CGI::Session driver
   170 
   171 =head1 SYNOPSIS
   172 
   173     $s = new CGI::Session();
   174     $s = new CGI::Session("driver:file", $sid);
   175     $s = new CGI::Session("driver:file", $sid, {Directory=>'/tmp'});
   176 
   177 
   178 =head1 DESCRIPTION
   179 
   180 When CGI::Session object is created without explicitly setting I<driver>, I<file> will be assumed.
   181 I<file> - driver will store session data in plain files, where each session will be stored in a separate
   182 file.
   183 
   184 Naming conventions of session files are defined by C<$CGI::Session::Driver::file::FileName> global variable. 
   185 Default value of this variable is I<cgisess_%s>, where %s will be replaced with respective session ID. Should
   186 you wish to set your own FileName template, do so before requesting for session object:
   187 
   188     $CGI::Session::Driver::file::FileName = "%s.dat";
   189     $s = new CGI::Session();
   190 
   191 For backwards compatibility with 3.x, you can also use the variable name
   192 C<$CGI::Session::File::FileName>, which will override the one above. 
   193 
   194 =head2 DRIVER ARGUMENTS
   195 
   196 If you wish to specify a session directory, use the B<Directory> option, which denotes location of the directory 
   197 where session ids are to be kept. If B<Directory> is not set, defaults to whatever File::Spec->tmpdir() returns. 
   198 So all the three lines in the SYNOPSIS section of this manual produce the same result on a UNIX machine.
   199 
   200 If specified B<Directory> does not exist, all necessary directory hierarchy will be created.
   201 
   202 By default, sessions are created with a umask of 0660. If you wish to change the umask for a session, pass
   203 a B<UMask> option with an octal representation of the umask you would like for said session. 
   204 
   205 =head1 NOTES
   206 
   207 If your OS doesn't support flock, you should understand the risks of going without locking the session files. Since
   208 sessions tend to be used in environments where race conditions may occur due to concurrent access of files by 
   209 different processes, locking tends to be seen as a good and very necessary thing. If you still want to use this 
   210 driver but don't want flock, set C<$CGI::Session::Driver::file::NoFlock> to 1 or pass C<< NoFlock => 1 >> and this 
   211 driver will operate without locks.
   212 
   213 =head1 LICENSING
   214 
   215 For support and licensing see L<CGI::Session|CGI::Session>
   216 
   217 =cut