[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.330 and 1.331

version 1.330, 2006/05/18 19:57:59 version 1.331, 2006/05/30 15:39:56
Line 58  my $DEBUG = 0;         # Non zero to ena Line 58  my $DEBUG = 0;         # Non zero to ena
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
 my $lond_max_wait_time = 13;  
   
 my $VERSION='$Revision$'; #' stupid emacs  my $VERSION='$Revision$'; #' stupid emacs
 my $remoteVERSION;  my $remoteVERSION;
Line 940  sub EditFile { Line 939  sub EditFile {
     return "ok\n";      return "ok\n";
 }  }
   
 #---------------------------------------------------------------  
 #  
 # 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($lond_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;  
     }  
 }  
   
 #   read_profile  #   read_profile
 #  #
 #   Returns a set of specific entries from a user's profile file.  #   Returns a set of specific entries from a user's profile file.
Line 5280  sub sub_sql_reply { Line 5095  sub sub_sql_reply {
     return $answer;      return $answer;
 }  }
   
 # -------------------------------------------- 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;  
 }   
   
 # --------------------------------------- Is this the home server of an author?  # --------------------------------------- Is this the home server of an author?
   
 sub ishome {  sub ishome {
Removed from v.1.330  
changed lines
  Added in v.1.331

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