[BACK]Return to LONCAPA.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/LONCAPA.pm between versions 1.1 and 1.2

version 1.1, 2006/05/08 22:05:54 version 1.2, 2006/05/30 12:45:12
Line 30 Line 30
 package LONCAPA;  package LONCAPA;
   
 use strict;  use strict;
   use lib '/home/httpd/lib/perl/';
   use LONCAPA::Configuration;
   use Fcntl qw(:flock);
   use GDBM_File;
   use POSIX;
   
   my $loncapa_max_wait_time = 13;
   
 require Exporter;  require Exporter;
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(&add_get_param &escape &unescape);  our @EXPORT = qw(&add_get_param &escape &unescape &tie_domain_hash &untie_domain_hash &tie_user_hash &untie_user_hash &propath);
   my %perlvar;
   
 # Inputs are a url, adn a hash ref of  # Inputs are a url, and a hash ref of
 # form name => value pairs  # form name => value pairs
 # takes care of properly adding the form name elements and values to the   # takes care of properly adding the form name elements and values to the 
 # the url doing proper escaping of the values and joining with ? or & as   # the url doing proper escaping of the values and joining with ? or & as 
Line 72  sub unescape { Line 81  sub unescape {
     return $str;      return $str;
 }  }
   
   # -------------------------------------------- Return path to profile directory
   
   sub propath {
       my ($udom,$uname)=@_;
       $udom=~s/\W//g;
       $uname=~s/\W//g;
       my $subdir=$uname.'__';
       $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
       my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
       return $proname;
   } 
   
   
   #---------------------------------------------------------------
   #
   # Manipulation of hash based databases (factoring out common code
   # for later use as we refactor.
   #
   #  Ties a domain level resource file to a hash.
   #  If requested a history entry is created in the associated hist file.
   #
   #  Parameters:
   #     domain    - Name of the domain in which the resource file lives.
   #     namespace - Name of the hash within that domain.
   #     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
   #     loghead   - Optional parameter, if present a log entry is created
   #                 in the associated history file and this is the first part
   #                  of that entry.
   #     logtail   - Goes along with loghead,  The actual logentry is of the
   #                 form $loghead:<timestamp>:logtail.
   # Returns:
   #    Reference to a hash bound to the db file or alternatively undef
   #    if the tie failed.
   #
   sub tie_domain_hash {
       my ($domain,$namespace,$how,$loghead,$logtail) = @_;
       
       # Filter out any whitespace in the domain name:
       
       $domain =~ s/\W//g;
       
       # We have enough to go on to tie the hash:
       
       my $user_top_dir   = $perlvar{'lonUsersDir'};
       my $domain_dir     = $user_top_dir."/$domain";
       my $resource_file  = $domain_dir."/$namespace";
       return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
   }
   
   sub untie_domain_hash {
       return &_locking_hash_untie(@_);
   }
   #
   #   Ties a user's resource file to a hash.  
   #   If necessary, an appropriate history
   #   log file entry is made as well.
   #   This sub factors out common code from the subs that manipulate
   #   the various gdbm files that keep keyword value pairs.
   # Parameters:
   #   domain       - Name of the domain the user is in.
   #   user         - Name of the 'current user'.
   #   namespace    - Namespace representing the file to tie.
   #   how          - What the tie is done to (e.g. GDBM_WRCREAT().
   #   loghead      - Optional first part of log entry if there may be a
   #                  history file.
   #   what         - Optional tail of log entry if there may be a history
   #                  file.
   # Returns:
   #   hash to which the database is tied.  It's up to the caller to untie.
   #   undef if the has could not be tied.
   #
   sub tie_user_hash {
       my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
   
       $namespace=~s/\//\_/g; # / -> _
       $namespace=~s/\W//g; # whitespace eliminated.
       my $proname     = &propath($domain, $user);
   
       my $file_prefix="$proname/$namespace";
       return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
   }
   
   sub untie_user_hash {
       return &_locking_hash_untie(@_);
   }
   
   # internal routines that handle the actual tieing and untieing process
   
   sub _do_hash_tie {
       my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
       my %hash;
       if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
    # If this is a namespace for which a history is kept,
    # make the history log entry:    
    if (($namespace !~/^nohist\_/) && (defined($loghead))) {
       my $args = scalar @_;
       Debug(" Opening history: $file_prefix $args");
       my $hfh = IO::File->new(">>$file_prefix.hist"); 
       if($hfh) {
    my $now = time;
    print $hfh "$loghead:$now:$what\n";
       }
       $hfh->close;
    }
    return \%hash;
       } else {
    return undef;
       }
   }
   
   sub _do_hash_untie {
       my ($hashref) = @_;
       my $result = untie(%$hashref);
       return $result;
   }
   
   {
       my $sym;
   
       sub _locking_hash_tie {
    my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
           my $lock_type=LOCK_SH;
   # Are we reading or writing?
           if ($how eq &GDBM_READER()) {
   # We are reading
              if (!open($sym,"$file_prefix.db.lock")) {
   # We don't have a lock file. This could mean
   # - that there is no such db-file
   # - that it does not have a lock file yet
                  if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
   # No such file. Forget it.                
                      $! = 2;
                      return undef;
                  }
   # Apparently just no lock file yet. Make one
                  open($sym,">>$file_prefix.db.lock");
              }
   # Do a shared lock
              if (!&flock_sym(LOCK_SH)) { return undef; } 
   # If this is compressed, we will actually need an exclusive lock
      if (-e "$file_prefix.db.gz") {
          if (!&flock_sym(LOCK_EX)) { return undef; }
      }
           } elsif ($how eq &GDBM_WRCREAT()) {
   # We are writing
              open($sym,">>$file_prefix.db.lock");
   # Writing needs exclusive lock
              if (!&flock_sym(LOCK_EX)) { return undef; }
           } else {
              &logthis("Unknown method $how for $file_prefix");
              die();
           }
   # The file is ours!
   # If it is archived, un-archive it now
          if (-e "$file_prefix.db.gz") {
              system("gunzip $file_prefix.db.gz");
      if (-e "$file_prefix.hist.gz") {
          system("gunzip $file_prefix.hist.gz");
      }
          }
   # Change access mode to non-blocking
          $how=$how|&GDBM_NOLOCK();
   # Go ahead and tie the hash
          return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
       }
   
       sub flock_sym {
           my ($lock_type)=@_;
    my $failed=0;
    eval {
       local $SIG{__DIE__}='DEFAULT';
       local $SIG{ALRM}=sub {
    $failed=1;
    die("failed lock");
       };
       alarm($loncapa_max_wait_time);
       flock($sym,$lock_type);
       alarm(0);
    };
    if ($failed) {
       $! = 100; # throwing error # 100
       return undef;
    } else {
       return 1;
    }
       }
   
       sub _locking_hash_untie {
    my ($hashref) = @_;
    my $result = untie(%$hashref);
    flock($sym,LOCK_UN);
    close($sym);
    undef($sym);
    return $result;
       }
   }
   
   BEGIN {
       my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
       %perlvar=%{$perlvarref};
       undef $perlvarref;
   }
   
 1;  1;
   
 __END__  __END__
Line 109  add_get_param() : Line 321  add_get_param() :
          as needed           as needed
   
 =back  =back
   
Removed from v.1.1  
changed lines
  Added in v.1.2

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>