lib/CPAN/lib/CGI/Session/Driver/db_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::db_file;
colas@0
     2
colas@0
     3
# $Id: db_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 DB_File;
colas@0
     9
use File::Spec;
colas@0
    10
use File::Basename;
colas@0
    11
use CGI::Session::Driver;
colas@0
    12
use Fcntl qw( :DEFAULT :flock );
colas@0
    13
use vars qw( @ISA $VERSION $FILE_NAME $UMask $NO_FOLLOW );
colas@0
    14
colas@0
    15
@ISA         = ( "CGI::Session::Driver" );
colas@0
    16
$VERSION     = "4.20";
colas@0
    17
$FILE_NAME   = "cgisess.db";
colas@0
    18
$UMask       = 0660;
colas@0
    19
$NO_FOLLOW   = eval { O_NOFOLLOW } || 0;
colas@0
    20
colas@0
    21
sub init {
colas@0
    22
    my $self = shift;
colas@0
    23
colas@0
    24
    $self->{FileName}  ||= $CGI::Session::Driver::db_file::FILE_NAME;
colas@0
    25
    unless ( $self->{Directory} ) {
colas@0
    26
        $self->{Directory} = dirname( $self->{FileName} );
colas@0
    27
        $self->{Directory} = File::Spec->tmpdir() if $self->{Directory} eq '.' && substr($self->{FileName},0,1) ne '.';
colas@0
    28
        $self->{FileName}  = basename( $self->{FileName} );
colas@0
    29
    }
colas@0
    30
    unless ( -d $self->{Directory} ) {
colas@0
    31
        require File::Path;
colas@0
    32
        File::Path::mkpath($self->{Directory}) or return $self->set_error("init(): couldn't mkpath: $!");
colas@0
    33
    }
colas@0
    34
    
colas@0
    35
    $self->{UMask} = $CGI::Session::Driver::db_file::UMask unless exists $self->{UMask};
colas@0
    36
    
colas@0
    37
    return 1;
colas@0
    38
}
colas@0
    39
colas@0
    40
colas@0
    41
sub retrieve {
colas@0
    42
    my $self = shift;
colas@0
    43
    my ($sid) = @_;
colas@0
    44
    croak "retrieve(): usage error" unless $sid;
colas@0
    45
colas@0
    46
    return 0 unless -f $self->_db_file; 
colas@0
    47
    my ($dbhash, $unlock) = $self->_tie_db_file(O_RDONLY) or return;
colas@0
    48
    my $datastr =  $dbhash->{$sid};
colas@0
    49
    untie(%$dbhash);
colas@0
    50
    $unlock->();
colas@0
    51
    return $datastr || 0;
colas@0
    52
}
colas@0
    53
colas@0
    54
colas@0
    55
sub store {
colas@0
    56
    my $self = shift;
colas@0
    57
    my ($sid, $datastr) = @_;
colas@0
    58
    croak "store(): usage error" unless $sid && $datastr;
colas@0
    59
colas@0
    60
    my ($dbhash, $unlock) = $self->_tie_db_file(O_RDWR, LOCK_EX) or return;
colas@0
    61
    $dbhash->{$sid} = $datastr;
colas@0
    62
    untie(%$dbhash);
colas@0
    63
    $unlock->();
colas@0
    64
    return 1;
colas@0
    65
}
colas@0
    66
colas@0
    67
colas@0
    68
colas@0
    69
sub remove {
colas@0
    70
    my $self = shift;
colas@0
    71
    my ($sid) = @_;
colas@0
    72
    croak "remove(): usage error" unless $sid;
colas@0
    73
colas@0
    74
    
colas@0
    75
    my ($dbhash, $unlock) = $self->_tie_db_file(O_RDWR, LOCK_EX) or return;
colas@0
    76
    delete $dbhash->{$sid};
colas@0
    77
    untie(%$dbhash);
colas@0
    78
    $unlock->();
colas@0
    79
    return 1;
colas@0
    80
}
colas@0
    81
colas@0
    82
colas@0
    83
sub DESTROY {}
colas@0
    84
colas@0
    85
colas@0
    86
sub _lock {
colas@0
    87
    my $self = shift;
colas@0
    88
    my ($db_file, $lock_type) = @_;
colas@0
    89
colas@0
    90
    croak "_lock(): usage error" unless $db_file;
colas@0
    91
    $lock_type ||= LOCK_SH;
colas@0
    92
colas@0
    93
    my $lock_file = $db_file . '.lck';
colas@0
    94
    if ( -l $lock_file ) {
colas@0
    95
        unlink($lock_file) or 
colas@0
    96
          die $self->set_error("_lock(): '$lock_file' appears to be a symlink and I can't remove it: $!");
colas@0
    97
    }
colas@0
    98
    sysopen(LOCKFH, $lock_file, O_RDWR|O_CREAT|$NO_FOLLOW) or die "couldn't create lock file '$lock_file': $!";
colas@0
    99
    
colas@0
   100
        
colas@0
   101
    flock(LOCKFH, $lock_type)                   or die "couldn't lock '$lock_file': $!";
colas@0
   102
    return sub {
colas@0
   103
        close(LOCKFH); # && unlink($lock_file); # keep the lock file around
colas@0
   104
        1;
colas@0
   105
    };
colas@0
   106
}
colas@0
   107
colas@0
   108
colas@0
   109
colas@0
   110
sub _tie_db_file {
colas@0
   111
    my $self                 = shift;
colas@0
   112
    my ($o_mode, $lock_type) = @_;
colas@0
   113
    $o_mode     ||= O_RDWR|O_CREAT;
colas@0
   114
    
colas@0
   115
    # DB_File will not touch a file unless it recognizes the format
colas@0
   116
    # we can't detect the version of the underlying database without some very heavy checks so the easiest thing is
colas@0
   117
    # to disable this for opening of the database
colas@0
   118
    
colas@0
   119
    # # protect against symlinks
colas@0
   120
    # $o_mode     |= $NO_FOLLOW;
colas@0
   121
colas@0
   122
    my $db_file     = $self->_db_file;
colas@0
   123
    my $unlock = $self->_lock($db_file, $lock_type);
colas@0
   124
    my %db;
colas@0
   125
        
colas@0
   126
    my $create = ! -e $db_file;
colas@0
   127
    
colas@0
   128
    if ( -l $db_file ) {
colas@0
   129
        $create = 1;
colas@0
   130
        unlink($db_file) or 
colas@0
   131
          return $self->set_error("_tie_db_file(): '$db_file' appears to be a symlink and I can't remove it: $!");
colas@0
   132
    }
colas@0
   133
    
colas@0
   134
    $o_mode = O_RDWR|O_CREAT|O_EXCL if $create;
colas@0
   135
    
colas@0
   136
    unless( tie %db, "DB_File", $db_file, $o_mode, $self->{UMask} ){
colas@0
   137
        $unlock->();
colas@0
   138
        return $self->set_error("_tie_db_file(): couldn't tie '$db_file': $!");
colas@0
   139
    }
colas@0
   140
colas@0
   141
    return (\%db, $unlock);
colas@0
   142
}
colas@0
   143
colas@0
   144
sub _db_file {
colas@0
   145
    my $self = shift;
colas@0
   146
    return File::Spec->catfile( $self->{Directory}, $self->{FileName} );
colas@0
   147
}
colas@0
   148
colas@0
   149
sub traverse {
colas@0
   150
    my $self = shift;
colas@0
   151
    my ($coderef) = @_;
colas@0
   152
colas@0
   153
    unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) {
colas@0
   154
        croak "traverse(): usage error";
colas@0
   155
    }
colas@0
   156
colas@0
   157
    my ($dbhash, $unlock) = $self->_tie_db_file(O_RDWR, LOCK_SH);
colas@0
   158
    unless ( $dbhash ) {
colas@0
   159
        return $self->set_error( "traverse(): couldn't get db handle, " . $self->errstr );
colas@0
   160
    }
colas@0
   161
    while ( my ($sid, undef) = each %$dbhash ) {
colas@0
   162
        $coderef->( $sid );
colas@0
   163
    }
colas@0
   164
    untie(%$dbhash);
colas@0
   165
    $unlock->();
colas@0
   166
    return 1;
colas@0
   167
}
colas@0
   168
colas@0
   169
colas@0
   170
1;
colas@0
   171
colas@0
   172
__END__;
colas@0
   173
colas@0
   174
=pod
colas@0
   175
colas@0
   176
=head1 NAME
colas@0
   177
colas@0
   178
CGI::Session::Driver::db_file - CGI::Session driver for BerkeleyDB using DB_File
colas@0
   179
colas@0
   180
=head1 SYNOPSIS
colas@0
   181
colas@0
   182
    $s = new CGI::Session("driver:db_file", $sid);
colas@0
   183
    $s = new CGI::Session("driver:db_file", $sid, {FileName=>'/tmp/cgisessions.db'});
colas@0
   184
colas@0
   185
=head1 DESCRIPTION
colas@0
   186
colas@0
   187
B<db_file> stores session data in BerkelyDB file using L<DB_File|DB_File> - Perl module. All sessions will be stored 
colas@0
   188
in a single file, specified in I<FileName> driver argument as in the above example. If I<FileName> isn't given, 
colas@0
   189
defaults to F</tmp/cgisess.db>, or its equivalent on a non-UNIX system.
colas@0
   190
colas@0
   191
If the directory hierarchy leading to the file does not exist, will be created for you.
colas@0
   192
colas@0
   193
This module takes a B<UMask> option which will be used if DB_File has to create the database file for you. By default
colas@0
   194
the umask is 0660.
colas@0
   195
colas@0
   196
=head1 LICENSING
colas@0
   197
colas@0
   198
For support and licensing information see L<CGI::Session|CGI::Session>
colas@0
   199
colas@0
   200
=cut
colas@0
   201