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

Diff for /loncom/lond between versions 1.324 and 1.331

version 1.324, 2006/03/29 19:56:10 version 1.331, 2006/05/30 15:39:56
Line 31 Line 31
   
 use strict;  use strict;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
   use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
 #use Apache::File;  #use Apache::File;
 use Symbol;  
 use POSIX;  use POSIX;
 use Crypt::IDEA;  use Crypt::IDEA;
 use LWP::UserAgent();  use LWP::UserAgent();
Line 53  use LONCAPA::ConfigFileEdit; Line 53  use LONCAPA::ConfigFileEdit;
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
 use LONCAPA::lonssl;  use LONCAPA::lonssl;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Symbol;  
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
 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 941  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);  
       
  if ($how eq &GDBM_READER()) {  
     $lock=LOCK_SH;  
     $how=$how|&GDBM_NOLOCK();  
     #if the db doesn't exist we can't read from it  
     if (! -e "$file_prefix.db") {  
  $! = 2;  
  return undef;  
     }  
  } elsif ($how eq &GDBM_WRCREAT()) {  
     $lock=LOCK_EX;  
     $how=$how|&GDBM_NOLOCK();  
     if (! -e "$file_prefix.db") {  
  # doesn't exist but we need it to in order to successfully  
                 # lock it so bring it into existance  
  open(TOUCH,">>$file_prefix.db");  
  close(TOUCH);  
     }  
  } else {  
     &logthis("Unknown method $how for $file_prefix");  
     die();  
  }  
       
  $sym=&Symbol::gensym();  
  open($sym,"$file_prefix.db");  
  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);  
     alarm(0);  
  };  
  if ($failed) {  
     $! = 100; # throwing error # 100  
     return undef;  
  }  
  return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);  
     }  
   
     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 2292  sub token_auth_user_file_handler { Line 2127  sub token_auth_user_file_handler {
     if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.      if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
      $session.'.id')) {       $session.'.id')) {
  while (my $line=<ENVIN>) {   while (my $line=<ENVIN>) {
     if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }      my ($envname)=split(/=/,$line,2);
       $envname=&unescape($envname);
       if ($envname=~ m|^userfile\.\Q$fname\E|) { $reply="ok\n"; }
  }   }
  close(ENVIN);   close(ENVIN);
  &Reply($client, $reply, "$cmd:$tail");   &Reply($client, $reply, "$cmd:$tail");
Line 5177  sub status { Line 5014  sub status {
     $0='lond: '.$what.' '.$local;      $0='lond: '.$what.' '.$local;
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  
   
 sub escape {  
     my $str=shift;  
     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------- Un-Escape Special Chars  
   
 sub unescape {  
     my $str=shift;  
     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------------- Send USR1 to lonc  # ----------------------------------------------------------- Send USR1 to lonc
   
 sub reconlonc {  sub reconlonc {
Line 5274  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 {
Line 6648  to the client, and the connection is clo Line 6457  to the client, and the connection is clo
 IO::Socket  IO::Socket
 IO::File  IO::File
 Apache::File  Apache::File
 Symbol  
 POSIX  POSIX
 Crypt::IDEA  Crypt::IDEA
 LWP::UserAgent()  LWP::UserAgent()
Removed from v.1.324  
changed lines
  Added in v.1.331

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