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

Diff for /loncom/lond between versions 1.305.2.6 and 1.308

version 1.305.2.6, 2006/05/18 19:58:36 version 1.308, 2006/01/27 23:04:27
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 89  my $ConnectionType; Line 87  my $ConnectionType;
   
 my %hostid; # ID's for hosts in cluster by ip.  my %hostid; # ID's for hosts in cluster by ip.
 my %hostdom; # LonCAPA domain for hosts in cluster.  my %hostdom; # LonCAPA domain for hosts in cluster.
   my %hostname; # DNSname -> ID's mapping.
 my %hostip; # IPs for hosts in cluster.  my %hostip; # IPs for hosts in cluster.
 my %hostdns; # ID's of hosts looked up by DNS name.  my %hostdns; # ID's of hosts looked up by DNS name.
   
Line 972  sub tie_domain_hash { Line 971  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";      my $resource_file  = $domain_dir."/$namespace.db";
     return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);      my %hash;
       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 {  
     return &_locking_hash_untie(@_);  
 }  
 #  #
 #   Ties a user's resource file to a hash.    #   Ties a user's resource file to a hash.  
 #   If necessary, an appropriate history  #   If necessary, an appropriate history
Line 1004  sub tie_user_hash { Line 1013  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);
      
     my $file_prefix="$proname/$namespace";      #  Tie the database.
     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', "$file_prefix.db", $how, 0640)) {      if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
      $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: $file_prefix $args");      Debug(" Opening history: $namespace $args");
     my $hfh = IO::File->new(">>$file_prefix.hist");       my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
     if($hfh) {      if($hfh) {
  my $now = time;   my $now = time;
  print $hfh "$loghead:$now:$what\n";   print $hfh "$loghead:$now:$what\n";
Line 1035  sub _do_hash_tie { Line 1035  sub _do_hash_tie {
     } else {      } else {
  return undef;   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
Line 1133  sub read_profile { Line 1068  sub read_profile {
     $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.      $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
  }   }
  $qresult=~s/\&$//;              # Remove trailing & from last lookup.   $qresult=~s/\&$//;              # Remove trailing & from last lookup.
  if (&untie_user_hash($hashref)) {   if (untie %$hashref) {
     return $qresult;      return $qresult;
  } else {   } else {
     return "error: ".($!+0)." untie (GDBM) Failed";      return "error: ".($!+0)." untie (GDBM) Failed";
Line 2291  sub token_auth_user_file_handler { Line 2226  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>) {
     my ($envname)=split(/=/,$line,2);      if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }
     $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 2444  sub put_user_profile_entry { Line 2377  sub put_user_profile_entry {
  my ($key,$value)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
  $hashref->{$key}=$value;   $hashref->{$key}=$value;
     }      }
     if (&untie_user_hash($hashref)) {      if (untie(%$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 2452  sub put_user_profile_entry { Line 2385  sub put_user_profile_entry {
  $userinput);   $userinput);
     }      }
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".      &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
      "while attempting put\n", $userinput);       "while attempting put\n", $userinput);
  }   }
     } else {      } else {
Line 2488  sub newput_user_profile_entry { Line 2421  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: ".($!+0)." tie(GDBM) Failed ".   &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
   "while attempting put\n", $userinput);    "while attempting put\n", $userinput);
  return 1;   return 1;
     }      }
Line 2507  sub newput_user_profile_entry { Line 2440  sub newput_user_profile_entry {
  $hashref->{$key}=$value;   $hashref->{$key}=$value;
     }      }
   
     if (&untie_user_hash($hashref)) {      if (untie(%$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 2560  sub increment_user_value_handler { Line 2493  sub increment_user_value_handler {
                     }                      }
                 }                  }
     }      }
     if (&untie_user_hash($hashref)) {      if (untie(%$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 2627  sub roles_put_handler { Line 2560  sub roles_put_handler {
        $auth_type);         $auth_type);
     $hashref->{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (&untie_user_hash($hashref)) {   if (untie($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 2678  sub roles_delete_handler { Line 2611  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(%$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 2819  sub delete_profile_entry { Line 2752  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(%$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 2861  sub get_profile_keys { Line 2794  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(%$hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 2922  sub dump_profile_database { Line 2855  sub dump_profile_database {
     $data{$symb}->{$param}=$value;      $data{$symb}->{$param}=$value;
     $data{$symb}->{'v.'.$param}=$v;      $data{$symb}->{'v.'.$param}=$v;
  }   }
  if (&untie_user_hash($hashref)) {   if (untie(%$hashref)) {
     while (my ($symb,$param_hash) = each(%data)) {      while (my ($symb,$param_hash) = each(%data)) {
  while(my ($param,$value) = each (%$param_hash)){   while(my ($param,$value) = each (%$param_hash)){
     next if ($param =~ /^v\./);       # Ignore versions...      next if ($param =~ /^v\./);       # Ignore versions...
Line 2977  sub dump_with_regexp { Line 2910  sub dump_with_regexp {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);      my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
     if (defined($regexp)) {      if (defined($regexp)) {
  $regexp=&unescape($regexp);   $regexp=&unescape($regexp);
     } else {      } else {
  $regexp='.';   $regexp='.';
     }      }
       my ($start,$end);
       if (defined($range)) {
    if ($range =~/^(\d+)\-(\d+)$/) {
       ($start,$end) = ($1,$2);
    } elsif ($range =~/^(\d+)$/) {
       ($start,$end) = (0,$1);
    } else {
       undef($range);
    }
       }
     my $hashref = &tie_user_hash($udom, $uname, $namespace,      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my $qresult='';          my $qresult='';
    my $count=0;
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
     if ($regexp eq '.') {      if ($regexp eq '.') {
    $count++;
    if (defined($range) && $count >= $end)   { last; }
    if (defined($range) && $count <  $start) { next; }
  $qresult.=$key.'='.$value.'&';   $qresult.=$key.'='.$value.'&';
     } else {      } else {
  my $unescapeKey = &unescape($key);   my $unescapeKey = &unescape($key);
  if (eval('$unescapeKey=~/$regexp/')) {   if (eval('$unescapeKey=~/$regexp/')) {
       $count++;
       if (defined($range) && $count >= $end)   { last; }
       if (defined($range) && $count <  $start) { next; }
     $qresult.="$key=$value&";      $qresult.="$key=$value&";
  }   }
     }      }
  }   }
  if (&untie_user_hash($hashref)) {   if (untie(%$hashref)) {
     chop($qresult);      chop($qresult);
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 3059  sub store_handler { Line 3009  sub store_handler {
     $hashref->{"$version:$rid:timestamp"}=$now;      $hashref->{"$version:$rid:timestamp"}=$now;
     $allkeys.='timestamp';      $allkeys.='timestamp';
     $hashref->{"$version:keys:$rid"}=$allkeys;      $hashref->{"$version:keys:$rid"}=$allkeys;
     if (&untie_user_hash($hashref)) {      if (untie($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 3111  sub restore_handler { Line 3061  sub restore_handler {
     $namespace=~s/\//\_/g;      $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;      $namespace=~s/\W//g;
     chomp($rid);      chomp($rid);
       my $proname=&propath($udom,$uname);
     my $qresult='';      my $qresult='';
     my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());      my %hash;
     if ($hashref) {      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
  my $version=$hashref->{"version:$rid"};      &GDBM_READER(),0640)) {
    my $version=$hash{"version:$rid"};
  $qresult.="version=$version&";   $qresult.="version=$version&";
  my $scope;   my $scope;
  for ($scope=1;$scope<=$version;$scope++) {   for ($scope=1;$scope<=$version;$scope++) {
     my $vkeys=$hashref->{"$scope:keys:$rid"};      my $vkeys=$hash{"$scope:keys:$rid"};
     my @keys=split(/:/,$vkeys);      my @keys=split(/:/,$vkeys);
     my $key;      my $key;
     $qresult.="$scope:keys=$vkeys&";      $qresult.="$scope:keys=$vkeys&";
     foreach $key (@keys) {      foreach $key (@keys) {
  $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";   $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
     }                                        }                                  
  }   }
  if (&untie_user_hash($hashref)) {   if (untie(%hash)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply( $client, "$qresult\n", $userinput);      &Reply( $client, "$qresult\n", $userinput);
  } else {   } else {
Line 3359  sub put_course_id_handler { Line 3311  sub put_course_id_handler {
             }              }
     $hashref->{$key}=$courseinfo.':'.$now;      $hashref->{$key}=$courseinfo.':'.$now;
  }   }
  if (&untie_domain_hash($hashref)) {   if (untie(%$hashref)) {
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)      &Failure($client, "error: ".($!+0)
Line 3475  sub dump_course_id_handler { Line 3427  sub dump_course_id_handler {
                 $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';                  $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
             }              }
  }   }
  if (&untie_domain_hash($hashref)) {   if (untie(%$hashref)) {
     chop($qresult);      chop($qresult);
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 3524  sub put_id_handler { Line 3476  sub put_id_handler {
     my ($key,$value)=split(/=/,$pair);      my ($key,$value)=split(/=/,$pair);
     $hashref->{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (&untie_domain_hash($hashref)) {   if (untie(%$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 3573  sub get_id_handler { Line 3525  sub get_id_handler {
  for (my $i=0;$i<=$#queries;$i++) {   for (my $i=0;$i<=$#queries;$i++) {
     $qresult.="$hashref->{$queries[$i]}&";      $qresult.="$hashref->{$queries[$i]}&";
  }   }
  if (&untie_domain_hash($hashref)) {   if (untie(%$hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 3617  sub put_dcmail_handler { Line 3569  sub put_dcmail_handler {
         my ($key,$value)=split(/=/,$what);          my ($key,$value)=split(/=/,$what);
         $hashref->{$key}=$value;          $hashref->{$key}=$value;
     }      }
     if (&untie_domain_hash($hashref)) {      if (untie(%$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 3697  sub dump_dcmail_handler { Line 3649  sub dump_dcmail_handler {
                 $qresult.=$key.'='.$value.'&';                  $qresult.=$key.'='.$value.'&';
             }              }
         }          }
         if (&untie_domain_hash($hashref)) {          if (untie(%$hashref)) {
             chop($qresult);              chop($qresult);
             &Reply($client, "$qresult\n", $userinput);              &Reply($client, "$qresult\n", $userinput);
         } else {          } else {
Line 3744  sub put_domainroles_handler { Line 3696  sub put_domainroles_handler {
             my ($key,$value)=split(/=/,$pair);              my ($key,$value)=split(/=/,$pair);
             $hashref->{$key}=$value;              $hashref->{$key}=$value;
         }          }
         if (&untie_domain_hash($hashref)) {          if (untie(%$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 3825  sub dump_domainroles_handler { Line 3777  sub dump_domainroles_handler {
                 $qresult.=$key.'='.$value.'&';                  $qresult.=$key.'='.$value.'&';
             }              }
         }          }
         if (&untie_domain_hash($hashref)) {          if (untie(%$hashref)) {
             chop($qresult);              chop($qresult);
             &Reply($client, "$qresult\n", $userinput);              &Reply($client, "$qresult\n", $userinput);
         } else {          } else {
Line 4320  sub get_institutional_code_format_handle Line 4272  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;  
     eval {  
  local($SIG{__DIE__})='DEFAULT';  
  $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,  
   \$conditions);  
     };  
     if (!$@) {  
  &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",  
        $userinput);  
     } else {  
  &Failure($client,"unknown_cmd\n",$userinput);  
     }  
     return 1;  
 }  
 &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);  
     return 1;  
 }  
 &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);  
     eval {  
  local($SIG{__DIE__})='DEFAULT';  
  ($update,$comment)    = &localenroll::manager_photo_update($cdom);  
     };  
     if (!$@) {  
  &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);  
     } else {  
  &Failure($client,"unknown_cmd\n",$userinput);  
     }  
     return 1;  
 }  
 &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 4409  sub photo_choice_handler { Line 4284  sub photo_choice_handler {
 #    $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,$ext,$type) = split(/:/, $tail);      my ($domain,$uname,$type) = split(/:/, $tail);
   
     my $path=&propath($domain,$uname). '/userfiles/internal/';      my $path=&propath($domain,$uname).
     my $filename = 'studentphoto.'.$ext;   '/userfiles/internal/studentphoto.'.$type;
     if ($type eq 'thumbnail') {      if (-e $path) {
         $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;      my $file=&localstudentphoto::fetch($domain,$uname);
     if ($type eq 'thumbnail') {  
  eval {  
     local($SIG{__DIE__})='DEFAULT';  
     $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.$filename) { &convert_photo($file,$path.$filename); }      if (!-e $path) { &convert_photo($file,$path); }
     if (-e $path.$filename) {      if (-e $path) {
  &Reply($client,"ok\n","$cmd:$tail");   &Reply($client,"ok\n","$cmd:$tail");
  return 1;   return 1;
     }      }
Line 4853  sub ReadHostTable { Line 4716  sub ReadHostTable {
     }      }
     $hostid{$ip}=$id;         # LonCAPA name of host by IP.      $hostid{$ip}=$id;         # LonCAPA name of host by IP.
     $hostdom{$id}=$domain;    # LonCAPA domain name of host.       $hostdom{$id}=$domain;    # LonCAPA domain name of host. 
       $hostname{$id}=$name;     # LonCAPA name -> DNS name
     $hostip{$id}=$ip;         # IP address of host.      $hostip{$id}=$ip;         # IP address of host.
     $hostdns{$name} = $id;    # LonCAPA name of host by DNS.      $hostdns{$name} = $id;    # LonCAPA name of host by DNS.
   
Line 5103  sub reconlonc { Line 4967  sub reconlonc {
   
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",      my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";         or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "sethost:$server:$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     if (!$answer) { $answer="con_lost"; }      if (!$answer) { $answer="con_lost"; }
Line 5124  sub reply { Line 4988  sub reply {
  $answer=subreply("ping",$server);   $answer=subreply("ping",$server);
         if ($answer ne $server) {          if ($answer ne $server) {
     &logthis("sub reply: answer != server answer is $answer, server is $server");      &logthis("sub reply: answer != server answer is $answer, server is $server");
            &reconlonc("$perlvar{'lonSockDir'}/$server");             &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});
         }          }
         $answer=subreply($cmd,$server);          $answer=subreply($cmd,$server);
     }      }
Line 5151  sub sub_sql_reply { Line 5015  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:$currentdomainid\n";      print $sclient "$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     if (!$answer) { $answer="con_lost"; }      if (!$answer) { $answer="con_lost"; }
Line 5430  sub make_new_child { Line 5294  sub make_new_child {
     # no need to try to do recon's to myself      # no need to try to do recon's to myself
     next;      next;
  }   }
  &reconlonc("$perlvar{'lonSockDir'}/$id");   &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});
     }      }
     &logthis("<font color='green'>Established connection: $clientname</font>");      &logthis("<font color='green'>Established connection: $clientname</font>");
     &status('Will listen to '.$clientname);      &status('Will listen to '.$clientname);
Line 5761  sub addline { Line 5625  sub addline {
   
 sub get_chat {  sub get_chat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname)=@_;
       my %hash;
       my $proname=&propath($cdom,$cname);
     my @entries=();      my @entries=();
     my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',      if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
  &GDBM_READER());      &GDBM_READER(),0640)) {
     if ($hashref) {   @entries=map { $_.':'.$hash{$_} } sort keys %hash;
  @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));   untie %hash;
  &untie_user_hash($hashref);  
     }      }
     my @participants=();      my @participants=();
     my $cutoff=time-60;      my $cutoff=time-60;
     $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',      if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
       &GDBM_WRCREAT());      &GDBM_WRCREAT(),0640)) {
     if ($hashref) {          $hash{$uname.':'.$udom}=time;
         $hashref->{$uname.':'.$udom}=time;          foreach (sort keys %hash) {
         foreach my $user (sort(keys(%$hashref))) {      if ($hash{$_}>$cutoff) {
     if ($hashref->{$user}>$cutoff) {   $participants[$#participants+1]='active_participant:'.$_;
  push(@participants, 'active_participant:'.$user);  
             }              }
         }          }
         &untie_user_hash($hashref);          untie %hash;
     }      }
     return (@participants,@entries);      return (@participants,@entries);
 }  }
   
 sub chat_add {  sub chat_add {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat)=@_;
       my %hash;
       my $proname=&propath($cdom,$cname);
     my @entries=();      my @entries=();
     my $time=time;      my $time=time;
     my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',      if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
  &GDBM_WRCREAT());      &GDBM_WRCREAT(),0640)) {
     if ($hashref) {   @entries=map { $_.':'.$hash{$_} } sort keys %hash;
  @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));  
  my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);   my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
  my ($thentime,$idnum)=split(/\_/,$lastid);   my ($thentime,$idnum)=split(/\_/,$lastid);
  my $newid=$time.'_000000';   my $newid=$time.'_000000';
Line 5802  sub chat_add { Line 5666  sub chat_add {
     $idnum=substr('000000'.$idnum,-6,6);      $idnum=substr('000000'.$idnum,-6,6);
     $newid=$time.'_'.$idnum;      $newid=$time.'_'.$idnum;
  }   }
  $hashref->{$newid}=$newchat;   $hash{$newid}=$newchat;
  my $expired=$time-3600;   my $expired=$time-3600;
  foreach my $comment (keys(%$hashref)) {   foreach (keys %hash) {
     my ($thistime) = ($comment=~/(\d+)\_/);      my ($thistime)=($_=~/(\d+)\_/);
     if ($thistime<$expired) {      if ($thistime<$expired) {
  delete $hashref->{$comment};   delete $hash{$_};
     }      }
  }   }
  {   untie %hash;
     my $proname=&propath($cdom,$cname);      }
     if (open(CHATLOG,">>$proname/chatroom.log")) {       {
  print CHATLOG ("$time:".&unescape($newchat)."\n");   my $hfh;
     }   if ($hfh=IO::File->new(">>$proname/chatroom.log")) { 
     close(CHATLOG);      print $hfh "$time:".&unescape($newchat)."\n";
  }   }
  &untie_user_hash($hashref);  
     }      }
 }  }
   
Removed from v.1.305.2.6  
changed lines
  Added in v.1.308

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