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

Diff for /loncom/lond between versions 1.311 and 1.319

version 1.311, 2006/01/31 15:37:41 version 1.319, 2006/02/08 17:11:46
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 971  sub tie_domain_hash { Line 973  sub tie_domain_hash {
           
     my $user_top_dir   = $perlvar{'lonUsersDir'};      my $user_top_dir   = $perlvar{'lonUsersDir'};
     my $domain_dir     = $user_top_dir."/$domain";      my $domain_dir     = $user_top_dir."/$domain";
     my $resource_file  = $domain_dir."/$namespace.db";      my $resource_file  = $domain_dir."/$namespace";
     my %hash;      return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
     if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) {  
  if (defined($loghead)) { # Need to log the operation.  
     my $logFh = IO::File->new(">>$domain_dir/$namespace.hist");  
     if($logFh) {  
  my $timestamp = time;  
  print $logFh "$loghead:$timestamp:$logtail\n";  
     }  
     $logFh->close;  
  }  
  return \%hash; # Return the tied hash.  
     } else {  
  return undef; # Tie failed.  
     }  
 }  }
   
 sub untie_domain_hash {  sub untie_domain_hash {
     my ($hashref) = @_;      return &_locking_hash_untie(@_);
     untie(%$hashref);  
 }  }
 #  #
 #   Ties a user's resource file to a hash.    #   Ties a user's resource file to a hash.  
Line 1017  sub tie_user_hash { Line 1005  sub tie_user_hash {
     $namespace=~s/\//\_/g; # / -> _      $namespace=~s/\//\_/g; # / -> _
     $namespace=~s/\W//g; # whitespace eliminated.      $namespace=~s/\W//g; # whitespace eliminated.
     my $proname     = propath($domain, $user);      my $proname     = propath($domain, $user);
      
     #  Tie the database.      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;      my %hash;
     if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",      if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
    $how, 0640)) {  
  # 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 $args = scalar @_;
     Debug(" Opening history: $namespace $args");      Debug(" Opening history: $file_prefix $args");
     my $hfh = IO::File->new(">>$proname/$namespace.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";
Line 1039  sub tie_user_hash { Line 1036  sub tie_user_hash {
     } else {      } else {
  return undef;   return undef;
     }      }
       
 }  }
   
 sub untie_user_hash {  sub _do_hash_untie {
     my ($hashref) = @_;      my ($hashref) = @_;
     my $result = untie(%$hashref);      my $result = untie(%$hashref);
     return $result;      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 2394  sub put_user_profile_entry { Line 2451  sub put_user_profile_entry {
  $userinput);   $userinput);
     }      }
  } else {   } else {
     &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
      "while attempting put\n", $userinput);       "while attempting put\n", $userinput);
  }   }
     } else {      } else {
Line 2430  sub newput_user_profile_entry { Line 2487  sub newput_user_profile_entry {
     my $hashref = &tie_user_hash($udom, $uname, $namespace,      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  &GDBM_WRCREAT(),"N",$what);   &GDBM_WRCREAT(),"N",$what);
     if(!$hashref) {      if(!$hashref) {
  &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
   "while attempting put\n", $userinput);    "while attempting put\n", $userinput);
  return 1;   return 1;
     }      }
Line 2620  sub roles_delete_handler { Line 2677  sub roles_delete_handler {
  foreach my $key (@rolekeys) {   foreach my $key (@rolekeys) {
     delete $hashref->{$key};      delete $hashref->{$key};
  }   }
  if (&untie_user_hash(%$hashref)) {   if (&untie_user_hash($hashref)) {
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2761  sub delete_profile_entry { Line 2818  sub delete_profile_entry {
  foreach my $key (@keys) {   foreach my $key (@keys) {
     delete($hashref->{$key});      delete($hashref->{$key});
  }   }
  if (&untie_user_hash(%$hashref)) {   if (&untie_user_hash($hashref)) {
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2803  sub get_profile_keys { Line 2860  sub get_profile_keys {
  foreach my $key (keys %$hashref) {   foreach my $key (keys %$hashref) {
     $qresult.="$key&";      $qresult.="$key&";
  }   }
  if (&untie_user_hash(%$hashref)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 4279  sub get_institutional_code_format_handle Line 4336  sub get_institutional_code_format_handle
 &register_handler("autoinstcodeformat",  &register_handler("autoinstcodeformat",
   \&get_institutional_code_format_handler,0,1,0);    \&get_institutional_code_format_handler,0,1,0);
   
   # Get domain specific conditions for import of student photographs to a course
   #
   # Retrieves information from photo_permission subroutine in localenroll.
   # Returns outcome (ok) if no processing errors, and whether course owner is 
   # required to accept conditions of use (yes/no).
   #
   #    
   sub photo_permission_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $cdom = $tail;
       my ($perm_reqd,$conditions);
       my $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
    \$conditions);
       &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
      $userinput);
   }
   &register_handler("autophotopermission",\&photo_permission_handler,0,1,0);
   
   #
   # Checks if student photo is available for a user in the domain, in the user's
   # directory (in /userfiles/internal/studentphoto.jpg).
   # Uses localstudentphoto:fetch() to ensure there is an up to date copy of
   # the student's photo.   
   
   sub photo_check_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my ($udom,$uname,$pid) = split(/:/,$tail);
       $udom = &unescape($udom);
       $uname = &unescape($uname);
       $pid = &unescape($pid);
       my $path=&propath($udom,$uname).'/userfiles/internal/';
       if (!-e $path) {
           &mkpath($path);
       }
       my $response;
       my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
       $result .= ':'.$response;
       &Reply($client, &escape($result)."\n",$userinput);
   }
   &register_handler("autophotocheck",\&photo_check_handler,0,1,0);
   
   #
   # Retrieve information from localenroll about whether to provide a button     
   # for users who have enbled import of student photos to initiate an 
   # update of photo files for registered students. Also include 
   # comment to display alongside button.  
   
   sub photo_choice_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput             = "$cmd:$tail";
       my $cdom                  = &unescape($tail);
       my ($update,$comment) = &localenroll::manager_photo_update($cdom);
       &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
   }
   &register_handler("autophotochoice",\&photo_choice_handler,0,1,0);
   
 #  #
 # Gets a student's photo to exist (in the correct image type) in the user's   # Gets a student's photo to exist (in the correct image type) in the user's 
 # directory.  # directory.
Line 4291  sub get_institutional_code_format_handle Line 4406  sub get_institutional_code_format_handle
 #    $client  - The socket open on the client.  #    $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1 - continue processing.  #    1 - continue processing.
   
 sub student_photo_handler {  sub student_photo_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     my ($domain,$uname,$type) = split(/:/, $tail);      my ($domain,$uname,$ext,$type) = split(/:/, $tail);
   
     my $path=&propath($domain,$uname).      my $path=&propath($domain,$uname). '/userfiles/internal/';
  '/userfiles/internal/studentphoto.'.$type;      my $filename = 'studentphoto.'.$ext;
     if (-e $path) {      if ($type eq 'thumbnail') {
           $filename = 'studentphoto_tn.'.$ext;
       }
       if (-e $path.$filename) {
  &Reply($client,"ok\n","$cmd:$tail");   &Reply($client,"ok\n","$cmd:$tail");
  return 1;   return 1;
     }      }
     &mkpath($path);      &mkpath($path);
     my $file=&localstudentphoto::fetch($domain,$uname);      my $file;
       if ($type eq 'thumbnail') {
           $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
       } else {
           $file=&localstudentphoto::fetch($domain,$uname);
       }
     if (!$file) {      if (!$file) {
  &Failure($client,"unavailable\n","$cmd:$tail");   &Failure($client,"unavailable\n","$cmd:$tail");
  return 1;   return 1;
     }      }
     if (!-e $path) { &convert_photo($file,$path); }      if (!-e $path.$filename) { &convert_photo($file,$path.$filename); }
     if (-e $path) {      if (-e $path.$filename) {
  &Reply($client,"ok\n","$cmd:$tail");   &Reply($client,"ok\n","$cmd:$tail");
  return 1;   return 1;
     }      }
Line 5022  sub sub_sql_reply { Line 5146  sub sub_sql_reply {
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";         or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "$cmd:$currentdomainid\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     if (!$answer) { $answer="con_lost"; }      if (!$answer) { $answer="con_lost"; }
Removed from v.1.311  
changed lines
  Added in v.1.319

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