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