colas@0: package CGI::Session::Driver::file;
colas@0: 
colas@0: # $Id: file.pm 351 2006-11-24 14:16:50Z markstos $
colas@0: 
colas@0: use strict;
colas@0: 
colas@0: use Carp;
colas@0: use File::Spec;
colas@0: use Fcntl qw( :DEFAULT :flock :mode );
colas@0: use CGI::Session::Driver;
colas@0: use vars qw( $FileName $NoFlock $UMask $NO_FOLLOW );
colas@0: 
colas@0: BEGIN {
colas@0:     # keep historical behavior
colas@0: 
colas@0:     no strict 'refs';
colas@0:     
colas@0:     *FileName = \$CGI::Session::File::FileName;
colas@0: }
colas@0: 
colas@0: @CGI::Session::Driver::file::ISA        = ( "CGI::Session::Driver" );
colas@0: $CGI::Session::Driver::file::VERSION    = "4.20";
colas@0: $FileName                               = "cgisess_%s";
colas@0: $NoFlock                                = 0;
colas@0: $UMask                                  = 0660;
colas@0: $NO_FOLLOW                              = eval { O_NOFOLLOW } || 0;
colas@0: 
colas@0: sub init {
colas@0:     my $self = shift;
colas@0:     $self->{Directory} ||= File::Spec->tmpdir();
colas@0: 
colas@0:     unless ( -d $self->{Directory} ) {
colas@0:         require File::Path;
colas@0:         unless ( File::Path::mkpath($self->{Directory}) ) {
colas@0:             return $self->set_error( "init(): couldn't create directory path: $!" );
colas@0:         }
colas@0:     }
colas@0:     
colas@0:     $self->{NoFlock} = $NoFlock unless exists $self->{NoFlock};
colas@0:     $self->{UMask} = $UMask unless exists $self->{UMask};
colas@0:     
colas@0:     return 1;
colas@0: }
colas@0: 
colas@0: sub _file {
colas@0:     my ($self,$sid) = @_;
colas@0:     return File::Spec->catfile($self->{Directory}, sprintf( $FileName, $sid ));
colas@0: }
colas@0: 
colas@0: sub retrieve {
colas@0:     my $self = shift;
colas@0:     my ($sid) = @_;
colas@0: 
colas@0:     my $path = $self->_file($sid);
colas@0:     
colas@0:     return 0 unless -e $path;
colas@0: 
colas@0:     # make certain our filehandle goes away when we fall out of scope
colas@0:     local *FH;
colas@0: 
colas@0:     if (-l $path) {
colas@0:         unlink($path) or 
colas@0:           return $self->set_error("retrieve(): '$path' appears to be a symlink and I couldn't remove it: $!");
colas@0:         return 0; # we deleted this so we have no hope of getting back anything
colas@0:     }
colas@0:     sysopen(FH, $path, O_RDONLY | $NO_FOLLOW ) || return $self->set_error( "retrieve(): couldn't open '$path': $!" );
colas@0:     
colas@0:     $self->{NoFlock} || flock(FH, LOCK_SH) or return $self->set_error( "retrieve(): couldn't lock '$path': $!" );
colas@0: 
colas@0:     my $rv = "";
colas@0:     while ( <FH> ) {
colas@0:         $rv .= $_;
colas@0:     }
colas@0:     close(FH);
colas@0:     return $rv;
colas@0: }
colas@0: 
colas@0: 
colas@0: 
colas@0: sub store {
colas@0:     my $self = shift;
colas@0:     my ($sid, $datastr) = @_;
colas@0:     
colas@0:     my $path = $self->_file($sid);
colas@0:     
colas@0:     # make certain our filehandle goes away when we fall out of scope
colas@0:     local *FH;
colas@0:     
colas@0:     my $mode = O_WRONLY|$NO_FOLLOW;
colas@0:     
colas@0:     # kill symlinks when we spot them
colas@0:     if (-l $path) {
colas@0:         unlink($path) or 
colas@0:           return $self->set_error("store(): '$path' appears to be a symlink and I couldn't remove it: $!");
colas@0:     }
colas@0:     
colas@0:     $mode = O_RDWR|O_CREAT|O_EXCL unless -e $path;
colas@0:     
colas@0:     sysopen(FH, $path, $mode, $self->{UMask}) or return $self->set_error( "store(): couldn't open '$path': $!" );
colas@0:     
colas@0:     # sanity check to make certain we're still ok
colas@0:     if (-l $path) {
colas@0:         return $self->set_error("store(): '$path' is a symlink, check for malicious processes");
colas@0:     }
colas@0:     
colas@0:     # prevent race condition (RT#17949)
colas@0:     $self->{NoFlock} || flock(FH, LOCK_EX)  or return $self->set_error( "store(): couldn't lock '$path': $!" );
colas@0:     truncate(FH, 0)  or return $self->set_error( "store(): couldn't truncate '$path': $!" );
colas@0:     
colas@0:     print FH $datastr;
colas@0:     close(FH)               or return $self->set_error( "store(): couldn't close '$path': $!" );
colas@0:     return 1;
colas@0: }
colas@0: 
colas@0: 
colas@0: sub remove {
colas@0:     my $self = shift;
colas@0:     my ($sid) = @_;
colas@0: 
colas@0:     my $directory = $self->{Directory};
colas@0:     my $file      = sprintf( $FileName, $sid );
colas@0:     my $path      = File::Spec->catfile($directory, $file);
colas@0:     unlink($path) or return $self->set_error( "remove(): couldn't unlink '$path': $!" );
colas@0:     return 1;
colas@0: }
colas@0: 
colas@0: 
colas@0: sub traverse {
colas@0:     my $self = shift;
colas@0:     my ($coderef) = @_;
colas@0: 
colas@0:     unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) {
colas@0:         croak "traverse(): usage error";
colas@0:     }
colas@0: 
colas@0:     opendir( DIRHANDLE, $self->{Directory} ) 
colas@0:         or return $self->set_error( "traverse(): couldn't open $self->{Directory}, " . $! );
colas@0: 
colas@0:     my $filename_pattern = $FileName;
colas@0:     $filename_pattern =~ s/\./\\./g;
colas@0:     $filename_pattern =~ s/\%s/(\.\+)/g;
colas@0:     while ( my $filename = readdir(DIRHANDLE) ) {
colas@0:         next if $filename =~ m/^\.\.?$/;
colas@0:         my $full_path = File::Spec->catfile($self->{Directory}, $filename);
colas@0:         my $mode = (stat($full_path))[2] 
colas@0:             or return $self->set_error( "traverse(): stat failed for $full_path: " . $! );
colas@0:         next if S_ISDIR($mode);
colas@0:         if ( $filename =~ /^$filename_pattern$/ ) {
colas@0:             $coderef->($1);
colas@0:         }
colas@0:     }
colas@0:     closedir( DIRHANDLE );
colas@0:     return 1;
colas@0: }
colas@0: 
colas@0: 
colas@0: sub DESTROY {
colas@0:     my $self = shift;
colas@0: }
colas@0: 
colas@0: 1;
colas@0: 
colas@0: __END__;
colas@0: 
colas@0: =pod
colas@0: 
colas@0: =head1 NAME
colas@0: 
colas@0: CGI::Session::Driver::file - Default CGI::Session driver
colas@0: 
colas@0: =head1 SYNOPSIS
colas@0: 
colas@0:     $s = new CGI::Session();
colas@0:     $s = new CGI::Session("driver:file", $sid);
colas@0:     $s = new CGI::Session("driver:file", $sid, {Directory=>'/tmp'});
colas@0: 
colas@0: 
colas@0: =head1 DESCRIPTION
colas@0: 
colas@0: When CGI::Session object is created without explicitly setting I<driver>, I<file> will be assumed.
colas@0: I<file> - driver will store session data in plain files, where each session will be stored in a separate
colas@0: file.
colas@0: 
colas@0: Naming conventions of session files are defined by C<$CGI::Session::Driver::file::FileName> global variable. 
colas@0: Default value of this variable is I<cgisess_%s>, where %s will be replaced with respective session ID. Should
colas@0: you wish to set your own FileName template, do so before requesting for session object:
colas@0: 
colas@0:     $CGI::Session::Driver::file::FileName = "%s.dat";
colas@0:     $s = new CGI::Session();
colas@0: 
colas@0: For backwards compatibility with 3.x, you can also use the variable name
colas@0: C<$CGI::Session::File::FileName>, which will override the one above. 
colas@0: 
colas@0: =head2 DRIVER ARGUMENTS
colas@0: 
colas@0: If you wish to specify a session directory, use the B<Directory> option, which denotes location of the directory 
colas@0: where session ids are to be kept. If B<Directory> is not set, defaults to whatever File::Spec->tmpdir() returns. 
colas@0: So all the three lines in the SYNOPSIS section of this manual produce the same result on a UNIX machine.
colas@0: 
colas@0: If specified B<Directory> does not exist, all necessary directory hierarchy will be created.
colas@0: 
colas@0: By default, sessions are created with a umask of 0660. If you wish to change the umask for a session, pass
colas@0: a B<UMask> option with an octal representation of the umask you would like for said session. 
colas@0: 
colas@0: =head1 NOTES
colas@0: 
colas@0: If your OS doesn't support flock, you should understand the risks of going without locking the session files. Since
colas@0: sessions tend to be used in environments where race conditions may occur due to concurrent access of files by 
colas@0: different processes, locking tends to be seen as a good and very necessary thing. If you still want to use this 
colas@0: driver but don't want flock, set C<$CGI::Session::Driver::file::NoFlock> to 1 or pass C<< NoFlock => 1 >> and this 
colas@0: driver will operate without locks.
colas@0: 
colas@0: =head1 LICENSING
colas@0: 
colas@0: For support and licensing see L<CGI::Session|CGI::Session>
colas@0: 
colas@0: =cut