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

Diff for /loncom/LONCAPA.pm between versions 1.4 and 1.31

version 1.4, 2006/05/30 19:26:34 version 1.31, 2011/05/14 16:12:53
Line 27 Line 27
 #  #
 ###  ###
   
   
   
 package LONCAPA;  package LONCAPA;
   
 use strict;  use strict;
Line 38  use POSIX; Line 40  use POSIX;
   
 my $loncapa_max_wait_time = 13;  my $loncapa_max_wait_time = 13;
   
   
   use vars qw($match_domain   $match_not_domain
       $match_username $match_not_username
       $match_courseid $match_not_courseid
               $match_community
       $match_name
               $match_lonid
       $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 &tie_domain_hash &untie_domain_hash &tie_user_hash &untie_user_hash &propath);  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_courseid $match_not_courseid
                       $match_community
       $match_name
       $match_lonid
       $match_handle   $match_not_handle);
   our %EXPORT_TAGS = ( 'match' =>[qw($match_domain   $match_not_domain
      $match_username $match_not_username
      $match_courseid $match_not_courseid
                                      $match_community
      $match_name
      $match_lonid
      $match_handle   $match_not_handle)],);
 my %perlvar;  my %perlvar;
   
 # Inputs are a url, and a hash ref of  
 # form name => value pairs  
 # 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   
 # needed  
   
 sub add_get_param {  sub add_get_param {
     my ($url,$form_data) = @_;      my ($url,$form_data) = @_;
Line 81  sub unescape { Line 103  sub unescape {
     return $str;      return $str;
 }  }
   
   $match_domain     = $LONCAPA::domain_re     = qr{[[:alnum:]\-.]+};
   $match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+};
   sub clean_domain {
       my ($domain) = @_;
       $domain =~ s/$match_not_domain//g;
       return $domain;
   }
   
   $match_username     = $LONCAPA::username_re     = qr{\w[\w\-.@]+};
   $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+};
   sub clean_username {
       my ($username) = @_;
       $username =~ s/^\W+//;
       $username =~ s/$match_not_username//g;
       return $username;
   }
   
   
   $match_courseid     = $LONCAPA::courseid_re     = qr{\d[\w\-.]+};
   $match_community    =$LONCAPA::community_re     = qr{0[\w\-.]+};
   $match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};
   sub clean_courseid {
       my ($courseid) = @_;
       $courseid =~ s/^\D+//;
       $courseid =~ s/$match_not_courseid//g;
       return $courseid;
   }
   
   $match_name         = $LONCAPA::name_re = qr{$match_username|$match_courseid};
   sub clean_name {
       my ($name) = @_;
       $name =~ s/$match_not_username//g;
       return $name;
   }
   
   $match_lonid     = $LONCAPA::lonid_re     = qr{[\w\-.]+};
   
   sub split_courseid {
       my ($courseid) = @_;
       my  ($domain,$coursenum) = 
    ($courseid=~m{^/($match_domain)/($match_courseid)});
       return ($domain,$coursenum);
   }
   
   $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;
   }
   
   #
   # -- Ensure another process for same filesystem action is not running.
   #    lond uses for: apachereload; loncron uses for: lciptables
   #
   
   sub try_to_lock {
       my ($lockfile)=@_;
       my $currentpid;
       my $lastpid;
       # Do not manipulate lock file as root
       if ($>==0) {
           return 0;
       }
       # Try to generate lock file.
       # Wait 3 seconds.  If same process id is in
       # lock file, then assume lock file is stale, and
       # go ahead.  If process id's fluctuate, try
       # for a maximum of 10 times.
       for (0..10) {
           if (-e $lockfile) { 
               open(LOCK,"<$lockfile");
               $currentpid=<LOCK>;
               close LOCK;
               if ($currentpid==$lastpid) {
                   last;
               }
               sleep 3;
               $lastpid=$currentpid;
           } else {
               last;
           }
           if ($_==10) {
               return 0;
           }
       }
       open(LOCK,">$lockfile");
       print LOCK $$;
       close LOCK;
       return 1;
   }
   
 # -------------------------------------------- Return path to profile directory  # -------------------------------------------- Return path to profile directory
   
 sub propath {  sub propath {
     my ($udom,$uname)=@_;      my ($udom,$uname)=@_;
     $udom=~s/\W//g;      $udom = &clean_domain($udom);
     $uname=~s/\W//g;      $uname= &clean_name($uname);
     my $subdir=$uname.'__';      my $subdir=$uname.'__';
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";      my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
     return $proname;      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 {  sub tie_domain_hash {
     my ($domain,$namespace,$how,$loghead,$logtail) = @_;      my ($domain,$namespace,$how,$loghead,$logtail) = @_;
           
     # Filter out any whitespace in the domain name:      # Filter out any whitespace in the domain name:
           
     $domain =~ s/\W//g;      $domain = &clean_domain($domain);
           
     # We have enough to go on to tie the hash:      # We have enough to go on to tie the hash:
           
Line 133  sub tie_domain_hash { Line 226  sub tie_domain_hash {
 sub untie_domain_hash {  sub untie_domain_hash {
     return &_locking_hash_untie(@_);      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 {  sub tie_user_hash {
     my ($domain,$user,$namespace,$how,$loghead,$what) = @_;      my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
   
     $namespace=~s/\//\_/g; # / -> _      $namespace=~s{/}{_}g; # / -> _
     $namespace=~s/\W//g; # whitespace eliminated.      $namespace     = &clean_username($namespace);
     my $proname     = &propath($domain, $user);      my $proname    = &propath($domain, $user);
   
     my $file_prefix="$proname/$namespace";      my $file_prefix="$proname/$namespace";
     return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);      return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
 }  }
Line 167  sub untie_user_hash { Line 242  sub untie_user_hash {
     return &_locking_hash_untie(@_);      return &_locking_hash_untie(@_);
 }  }
   
   
   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  # internal routines that handle the actual tieing and untieing process
   
 sub _do_hash_tie {  sub _do_hash_tie {
Line 176  sub _do_hash_tie { Line 270  sub _do_hash_tie {
  # If this is a namespace for which a history is kept,   # If this is a namespace for which a history is kept,
  # make the history log entry:       # make the history log entry:    
  if (($namespace !~/^nohist\_/) && (defined($loghead))) {   if (($namespace !~/^nohist\_/) && (defined($loghead))) {
     my $args = scalar @_;  
     my $hfh = IO::File->new(">>$file_prefix.hist");       my $hfh = IO::File->new(">>$file_prefix.hist"); 
     if($hfh) {      if($hfh) {
  my $now = time;   my $now = time();
  print $hfh "$loghead:$now:$what\n";   print $hfh ("$loghead:$now:$what\n");
     }      }
     $hfh->close;      $hfh->close;
  }   }
Line 198  sub _do_hash_untie { Line 291  sub _do_hash_untie {
   
 {  {
     my $sym;      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 {      sub _locking_hash_tie {
  my ($file_prefix,$namespace,$how,$loghead,$what) = @_;   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;          my $lock_type=LOCK_SH;
 # Are we reading or writing?  # Are we reading or writing?
         if ($how eq &GDBM_READER()) {          if ($how eq &GDBM_READER()) {
Line 212  sub _do_hash_untie { Line 328  sub _do_hash_untie {
                if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {                 if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
 # No such file. Forget it.                  # No such file. Forget it.                
                    $! = 2;                     $! = 2;
      &clean_sym();
                    return undef;                     return undef;
                }                 }
 # Apparently just no lock file yet. Make one  # Apparently just no lock file yet. Make one
                open($sym,">>$file_prefix.db.lock");                 open($sym,">>$file_prefix.db.lock");
            }             }
 # Do a shared lock  # Do a shared lock
            if (!&flock_sym(LOCK_SH)) { return undef; }              if (!&flock_sym(LOCK_SH)) { 
          &clean_sym();
          return undef; 
      } 
 # If this is compressed, we will actually need an exclusive lock  # If this is compressed, we will actually need an exclusive lock
    if (-e "$file_prefix.db.gz") {     if (-e "$file_prefix.db.gz") {
        if (!&flock_sym(LOCK_EX)) { return undef; }         if (!&flock_sym(LOCK_EX)) {
      &clean_sym();
      return undef;
          }
    }     }
         } elsif ($how eq &GDBM_WRCREAT()) {          } elsif ($how eq &GDBM_WRCREAT()) {
 # We are writing  # We are writing
            open($sym,">>$file_prefix.db.lock");             open($sym,">>$file_prefix.db.lock");
 # Writing needs exclusive lock  # Writing needs exclusive lock
            if (!&flock_sym(LOCK_EX)) { return undef; }             if (!&flock_sym(LOCK_EX)) {
          &clean_sym();
          return undef;
      }
         } else {          } else {
            &logthis("Unknown method $how for $file_prefix");             die("Unknown method $how for $file_prefix");
            die();  
         }          }
 # The file is ours!  # The file is ours!
 # If it is archived, un-archive it now  # If it is archived, un-archive it now
Line 243  sub _do_hash_untie { Line 368  sub _do_hash_untie {
 # Change access mode to non-blocking  # Change access mode to non-blocking
        $how=$how|&GDBM_NOLOCK();         $how=$how|&GDBM_NOLOCK();
 # Go ahead and tie the hash  # Go ahead and tie the hash
        return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);        my $result = 
       &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
    if (!$result) {
       &clean_sym();
    }
    return $result;
     }      }
   
     sub flock_sym {      sub flock_sym {
Line 272  sub _do_hash_untie { Line 402  sub _do_hash_untie {
  my $result = untie(%$hashref);   my $result = untie(%$hashref);
  flock($sym,LOCK_UN);   flock($sym,LOCK_UN);
  close($sym);   close($sym);
  undef($sym);   &clean_sym();
  return $result;   return $result;
     }      }
 }  }
Line 289  __END__ Line 419  __END__
   
 =head1 NAME  =head1 NAME
   
   Apache::LONCAPA
   
 LONCAPA - Basic routines  LONCAPA - Basic routines
   
 =head1 SYNOPSIS  =head1 SYNOPSIS
Line 297  Generally useful routines Line 429  Generally useful routines
   
 =head1 EXPORTED SUBROUTINES  =head1 EXPORTED SUBROUTINES
   
 =over 4  =over
   
 =item *  =item escape()
   
 escape() : unpack non-word characters into CGI-compatible hex codes  unpack non-word characters into CGI-compatible hex codes
   
 =item *  =item unescape()
   
 unescape() : pack CGI-compatible hex codes into actual non-word ASCII character   pack CGI-compatible hex codes into actual non-word ASCII character
   
 =item *  =item  add_get_param()
   
 add_get_param() :  Append escaped form elements (name=value etc.) to a url.
    
  Inputs:  url (with or without exit GET from parameters), hash ref of   Inputs:  url (with or without exit GET from parameters), hash ref of
               form name => value pairs                form name => value pairs
   
  Return: url with properly added the form name elements and values to the    Return: url with form name elements and values appended to the 
          the url doing proper escaping of the values and joining with ? or &           the url, doing proper escaping of the values and joining with ? or &
          as needed           as needed
   
   =item clean_handle()
   
   =item propath()
   
   =item untie_domain_hash()
   
   =item tie_domain_hash()
   
   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.
   
   =item tie_user_hash()
   
     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.
   
   =item locking_hash_tie()
   
   routines if you just have a filename return tied hashref or undef
   
   =item locking_hash_untie()
   
   =item db_filename_parts()
   
   =head1 INTERNAL SUBROUTINES
   
   =item _do_hash_tie()
   
   =item _do_hash_untie()
   
 =back  =back
   
   =cut
   
Removed from v.1.4  
changed lines
  Added in v.1.31

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