View of /trunk/webwork2/lib/WeBWorK/DB/GDBM.pm

    1 ################################################################################
    2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project
    3 # $Id$
    4 ################################################################################
    5 
    6 package WeBWorK::DB::GDBM;
    7 
    8 =head1 NAME
    9 
   10 WeBWorK::DB::GDBM - connect to a GDBM database.
   11 
   12 =cut
   13 
   14 use strict;
   15 use warnings;
   16 use GDBM_File;
   17 
   18 # these should probably be in a constants file somewhere...
   19 use constant MAX_TIE_ATTEMPTS => 30;
   20 use constant TIE_RETRY_DELAY  => 2;
   21 use constant TIE_PERMISSION => 0660;
   22 
   23 sub new($$) {
   24   my $proto = shift;
   25   my $class = ref($proto) || $proto;
   26   my $self = {
   27     hashRef    => {},
   28     gdbm_file  => shift,
   29   };
   30   bless $self, $class;
   31   return $self;
   32 }
   33 
   34 # connect($self, $symbolicFlags)
   35 # $self     implicitly set by caller
   36 # $symbolicFlags  "ro" = read-only, "rw" = read-write
   37 # returns:
   38 # -1 = already tied
   39 #  0 = file doesn't exist when being opened for reading
   40 # >0 = success! (number of attempts to tie)
   41 sub connect($$) {
   42   my $self = shift;
   43   my $symbolicFlags = shift; # "ro" or "rw"
   44   return -1 if tied %$self->{hashRef}; # already tied!
   45   my $flags = lc $symbolicFlags eq "rw" ? GDBM_WRCREAT() : GDBM_READER();
   46   return 0 if lc $symbolicFlags eq "ro" and not -e $self->{gdbm_file};
   47   foreach (1 .. MAX_TIE_ATTEMPTS) {
   48     return 1 if tie %{$self->{hashRef}},
   49       "GDBM_File",        # class
   50       $self->{gdbm_file}, # file name
   51       $flags,             # I/O flags
   52       TIE_PERMISSION;     # access mode
   53     sleep TIE_RETRY_DELAY;
   54   }
   55   die "unable to tie ", $self->{gdbm_file}, ": $!";
   56 }
   57 
   58 sub hashRef($) {
   59   my $self = shift;
   60   return unless tied %{$self->{hashRef}}; # not tied!
   61   return $self->{hashRef};
   62 }
   63 
   64 sub disconnect($) {
   65   my $self = shift;
   66   return unless tied %{$self->{hashRef}}; # not tied!
   67   return untie %{$self->{hashRef}};
   68 }
   69 
   70 1;