[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.14

version 1.1, 2006/05/08 22:05:54 version 1.14, 2006/11/22 19:58:29
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;
   
   
   use vars qw($match_domain   $match_not_domain
       $match_username $match_not_username
       $match_handle   $match_not_handle);
   
 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);
   our @EXPORT_OK = qw($match_domain   $match_not_domain
       $match_username $match_not_username
       $match_handle   $match_not_handle);
   our %EXPORT_TAGS = ( 'match' =>[qw($match_domain   $match_not_domain
      $match_username $match_not_username
      $match_handle   $match_not_handle)],);
   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 96  sub unescape {
     return $str;      return $str;
 }  }
   
   $match_domain     = $LONCAPA::domain_re     = qr{[\w\-.]+};
   $match_not_domain = $LONCAPA::not_domain_re = qr{[^\w\-.]+};
   sub clean_domain {
       my ($domain) = @_;
       $domain =~ s/$match_not_domain//g;
       return $domain;
   }
   
   sub split_courseid {
       my ($courseid) = @_;
       my  ($domain,$coursenum) = 
    ($courseid=~m{^/($match_domain)/($match_username)});
       return ($domain,$coursenum);
   }
   
   $match_username     = $LONCAPA::username_re     = qr{[\w\-.]+};
   $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.]+};
   sub clean_username {
       my ($username) = @_;
       $username =~ s/$match_not_username//g;
       return $username;
   }
   
   $match_handle     = $LONCAPA::handle_re     = qr{[\w\-.]+};
   $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.]+};
   sub clean_handle {
       my ($handle) = @_;
       $handle =~ s/$match_not_handle//g;
       return $handle;
   }
   
   # -------------------------------------------- Return path to profile directory
   
   sub propath {
       my ($udom,$uname)=@_;
       $udom = &clean_domain($udom);
       $uname= &clean_username($uname);
       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 = &clean_domain($domain);
       
       # 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(@_);
   }
   
   # routines if you just have a filename
   # return tied hashref or undef
   
   sub locking_hash_tie {
       my ($filename,$how)=@_;
       my ($file_prefix,$namespace)=&db_filename_parts($filename);
       if ($namespace eq '') { return undef; }
       return &_locking_hash_tie($file_prefix,$namespace,$how);
   }
   
   sub locking_hash_untie {
       return &_locking_hash_untie(@_);
   }
   
   sub db_filename_parts {
       my ($filename)=@_;
       my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/);
       if ($namespace eq '') { return undef; }
       return ($file_path.'/'.$namespace,$namespace);
   }
   
   # 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 $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;
       my @pushed_syms;
   
       sub clean_sym {
    undef($sym);
       }
       sub push_locking_hash_tie {
    if (!defined($sym)) {
       die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
    }
    push(@pushed_syms,$sym);
    undef($sym);
       }
   
       sub pop_locking_hash_tie {
    if (defined($sym)) {
       die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
    }
    $sym = pop(@pushed_syms);
       }
   
       sub _locking_hash_tie {
    my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
    if (defined($sym)) {
       die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
    }
   
           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;
      &clean_sym();
                      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)) { 
          &clean_sym();
          return undef; 
      } 
   # If this is compressed, we will actually need an exclusive lock
      if (-e "$file_prefix.db.gz") {
          if (!&flock_sym(LOCK_EX)) {
      &clean_sym();
      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)) {
          &clean_sym();
          return undef;
      }
           } else {
              die("Unknown method $how for $file_prefix");
           }
   # 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
         my $result = 
       &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
    if (!$result) {
       &clean_sym();
    }
    return $result;
       }
   
       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);
    &clean_sym();
    return $result;
       }
   }
   
   BEGIN {
       %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
   }
   
 1;  1;
   
 __END__  __END__
Line 109  add_get_param() : Line 421  add_get_param() :
          as needed           as needed
   
 =back  =back
   
Removed from v.1.1  
changed lines
  Added in v.1.14

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