[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.312

version 1.305.2.6, 2006/05/18 19:58:36 version 1.312, 2006/01/31 15:56: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 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 973  sub tie_domain_hash { Line 972  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";
     return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);      return &_do_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
 }  }
   
 sub untie_domain_hash {  sub untie_domain_hash {
     return &_locking_hash_untie(@_);      return &_do_hash_untie(@_);
 }  }
 #  #
 #   Ties a user's resource file to a hash.    #   Ties a user's resource file to a hash.  
Line 1006  sub tie_user_hash { Line 1005  sub tie_user_hash {
     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 &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
 }  }
   
 sub untie_user_hash {  sub untie_user_hash {
     return &_locking_hash_untie(@_);      return &_do_hash_untie(@_);
 }  }
   
 # internal routines that handle the actual tieing and untieing process  # internal routines that handle the actual tieing and untieing process
Line 1042  sub _do_hash_untie { Line 1041  sub _do_hash_untie {
     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 2291  sub token_auth_user_file_handler { Line 2229  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 2452  sub put_user_profile_entry { Line 2388  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 2424  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 2678  sub roles_delete_handler { Line 2614  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 2819  sub delete_profile_entry { Line 2755  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 2861  sub get_profile_keys { Line 2797  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 2977  sub dump_with_regexp { Line 2913  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&";
  }   }
     }      }
Line 4320  sub get_institutional_code_format_handle Line 4273  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 4285  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 4717  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 4968  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 4989  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 5016  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 5295  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);
Removed from v.1.305.2.6  
changed lines
  Added in v.1.312

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