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

Diff for /loncom/lond between versions 1.287 and 1.305.2.4

version 1.287, 2005/06/27 10:27:02 version 1.305.2.4, 2006/02/10 09:48:17
Line 48  use localauth; Line 48  use localauth;
 use localenroll;  use localenroll;
 use localstudentphoto;  use localstudentphoto;
 use File::Copy;  use File::Copy;
   use File::Find;
 use LONCAPA::ConfigFileEdit;  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 969  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.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 {
       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 1011  sub tie_user_hash { Line 1004  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 1033  sub tie_user_hash { Line 1035  sub tie_user_hash {
     } 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 1066  sub read_profile { Line 1133  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 %$hashref) {   if (&untie_user_hash($hashref)) {
     return $qresult;      return $qresult;
  } else {   } else {
     return "error: ".($!+0)." untie (GDBM) Failed";      return "error: ".($!+0)." untie (GDBM) Failed";
Line 1363  sub du_handler { Line 1430  sub du_handler {
     #  etc.      #  etc.
     #      #
     if (-d $ududir) {      if (-d $ududir) {
  #  And as Shakespeare would say to make   my $total_size=0;
  #  assurance double sure,    my $code=sub { 
  # use execute_command to ensure that the command is not executed in      if ($_=~/\.\d+\./) { return;} 
  # a shell that can screw us up.      if ($_=~/\.meta$/) { return;}
       $total_size+=(stat($_))[7];
  my $duout = execute_command("du -ks $ududir");   };
  $duout=~s/[^\d]//g; #preserve only the numbers   chdir($ududir);
  &Reply($client,"$duout\n","$cmd:$ududir");   find($code,$ududir);
    $total_size=int($total_size/1024);
    &Reply($client,"$total_size\n","$cmd:$ududir");
     } else {      } else {
   
  &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");    &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); 
   
     }      }
     return 1;      return 1;
 }  }
Line 1413  sub ls_handler { Line 1480  sub ls_handler {
  if(-d $ulsdir) {   if(-d $ulsdir) {
     if (opendir(LSDIR,$ulsdir)) {      if (opendir(LSDIR,$ulsdir)) {
  while ($ulsfn=readdir(LSDIR)) {   while ($ulsfn=readdir(LSDIR)) {
     undef $obs, $rights;       undef($obs);
       undef($rights); 
     my @ulsstats=stat($ulsdir.'/'.$ulsfn);      my @ulsstats=stat($ulsdir.'/'.$ulsfn);
     #We do some obsolete checking here      #We do some obsolete checking here
     if(-e $ulsdir.'/'.$ulsfn.".meta") {       if(-e $ulsdir.'/'.$ulsfn.".meta") { 
  open(FILE, $ulsdir.'/'.$ulsfn.".meta");   open(FILE, $ulsdir.'/'.$ulsfn.".meta");
  my @obsolete=<FILE>;   my @obsolete=<FILE>;
  foreach my $obsolete (@obsolete) {   foreach my $obsolete (@obsolete) {
     if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }       if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 
     if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }      if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
  }   }
     }      }
Line 1480  sub ls2_handler { Line 1548  sub ls2_handler {
         if(-d $ulsdir) {          if(-d $ulsdir) {
             if (opendir(LSDIR,$ulsdir)) {              if (opendir(LSDIR,$ulsdir)) {
                 while ($ulsfn=readdir(LSDIR)) {                  while ($ulsfn=readdir(LSDIR)) {
                     undef $obs, $rights;                       undef($obs);
       undef($rights); 
                     my @ulsstats=stat($ulsdir.'/'.$ulsfn);                      my @ulsstats=stat($ulsdir.'/'.$ulsfn);
                     #We do some obsolete checking here                      #We do some obsolete checking here
                     if(-e $ulsdir.'/'.$ulsfn.".meta") {                       if(-e $ulsdir.'/'.$ulsfn.".meta") { 
                         open(FILE, $ulsdir.'/'.$ulsfn.".meta");                          open(FILE, $ulsdir.'/'.$ulsfn.".meta");
                         my @obsolete=<FILE>;                          my @obsolete=<FILE>;
                         foreach my $obsolete (@obsolete) {                          foreach my $obsolete (@obsolete) {
                             if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }                               if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 
                             if($obsolete =~ m|(<copyright>)(default)|) {                              if($obsolete =~ m|(<copyright>)(default)|) {
                                 $rights = 1;                                  $rights = 1;
                             }                              }
Line 1835  sub change_authentication_handler { Line 1904  sub change_authentication_handler {
  &logthis("Result of password change for $uname: ".$result);   &logthis("Result of password change for $uname: ".$result);
  if ($result eq "ok") {   if ($result eq "ok") {
     &Reply($client, "$result\n")      &Reply($client, "$result\n")
  }   } else {
  else {  
     &Failure($client, "$result\n");      &Failure($client, "$result\n");
  }   }
     }      } else {
     else {  
  my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);   my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
  #   #
  #  If the current auth mode is internal, and the old auth mode was   #  If the current auth mode is internal, and the old auth mode was
Line 1942  sub update_resource_handler { Line 2009  sub update_resource_handler {
     my $since=$now-$atime;      my $since=$now-$atime;
     if ($since>$perlvar{'lonExpire'}) {      if ($since>$perlvar{'lonExpire'}) {
  my $reply=&reply("unsub:$fname","$clientname");   my $reply=&reply("unsub:$fname","$clientname");
    &devalidate_meta_cache($fname);
  unlink("$fname");   unlink("$fname");
     } else {      } else {
  my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
Line 1972  sub update_resource_handler { Line 2040  sub update_resource_handler {
  alarm(0);   alarm(0);
     }      }
     rename($transname,$fname);      rename($transname,$fname);
       &devalidate_meta_cache($fname);
  }   }
     }      }
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
Line 1985  sub update_resource_handler { Line 2054  sub update_resource_handler {
 }  }
 &register_handler("update", \&update_resource_handler, 0 ,1, 0);  &register_handler("update", \&update_resource_handler, 0 ,1, 0);
   
   sub devalidate_meta_cache {
       my ($url) = @_;
       use Cache::Memcached;
       my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
       $url = &declutter($url);
       $url =~ s-\.meta$--;
       my $id = &escape('meta:'.$url);
       $memcache->delete($id);
   }
   
   sub declutter {
       my $thisfn=shift;
       $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
       $thisfn=~s/^\///;
       $thisfn=~s|^adm/wrapper/||;
       $thisfn=~s|^adm/coursedocs/showdoc/||;
       $thisfn=~s/^res\///;
       $thisfn=~s/\?.+$//;
       return $thisfn;
   }
 #  #
 #   Fetch a user file from a remote server to the user's home directory  #   Fetch a user file from a remote server to the user's home directory
 #   userfiles subdir.  #   userfiles subdir.
Line 2353  sub put_user_profile_entry { Line 2442  sub put_user_profile_entry {
  my ($key,$value)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
  $hashref->{$key}=$value;   $hashref->{$key}=$value;
     }      }
     if (untie(%$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 2361  sub put_user_profile_entry { Line 2450  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 2397  sub newput_user_profile_entry { Line 2486  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 2416  sub newput_user_profile_entry { Line 2505  sub newput_user_profile_entry {
  $hashref->{$key}=$value;   $hashref->{$key}=$value;
     }      }
   
     if (untie(%$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 2469  sub increment_user_value_handler { Line 2558  sub increment_user_value_handler {
                     }                      }
                 }                  }
     }      }
     if (untie(%$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 2536  sub roles_put_handler { Line 2625  sub roles_put_handler {
        $auth_type);         $auth_type);
     $hashref->{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (untie($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 2587  sub roles_delete_handler { Line 2676  sub roles_delete_handler {
  foreach my $key (@rolekeys) {   foreach my $key (@rolekeys) {
     delete $hashref->{$key};      delete $hashref->{$key};
  }   }
  if (untie(%$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 2728  sub delete_profile_entry { Line 2817  sub delete_profile_entry {
  foreach my $key (@keys) {   foreach my $key (@keys) {
     delete($hashref->{$key});      delete($hashref->{$key});
  }   }
  if (untie(%$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 2770  sub get_profile_keys { Line 2859  sub get_profile_keys {
  foreach my $key (keys %$hashref) {   foreach my $key (keys %$hashref) {
     $qresult.="$key&";      $qresult.="$key&";
  }   }
  if (untie(%$hashref)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 2831  sub dump_profile_database { Line 2920  sub dump_profile_database {
     $data{$symb}->{$param}=$value;      $data{$symb}->{$param}=$value;
     $data{$symb}->{'v.'.$param}=$v;      $data{$symb}->{'v.'.$param}=$v;
  }   }
  if (untie(%$hashref)) {   if (&untie_user_hash($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 2906  sub dump_with_regexp { Line 2995  sub dump_with_regexp {
  }   }
     }      }
  }   }
  if (untie(%$hashref)) {   if (&untie_user_hash($hashref)) {
     chop($qresult);      chop($qresult);
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 2968  sub store_handler { Line 3057  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($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 3020  sub restore_handler { Line 3109  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 %hash;      my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",      if ($hashref) {
     &GDBM_READER(),0640)) {   my $version=$hashref->{"version:$rid"};
  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=$hash{"$scope:keys:$rid"};      my $vkeys=$hashref->{"$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=".$hash{"$scope:$rid:$key"}."&";   $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
     }                                        }                                  
  }   }
  if (untie(%hash)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply( $client, "$qresult\n", $userinput);      &Reply( $client, "$qresult\n", $userinput);
  } else {   } else {
Line 3270  sub put_course_id_handler { Line 3357  sub put_course_id_handler {
             }              }
     $hashref->{$key}=$courseinfo.':'.$now;      $hashref->{$key}=$courseinfo.':'.$now;
  }   }
  if (untie(%$hashref)) {   if (&untie_domain_hash($hashref)) {
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)      &Failure($client, "error: ".($!+0)
Line 3386  sub dump_course_id_handler { Line 3473  sub dump_course_id_handler {
                 $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';                  $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
             }              }
  }   }
  if (untie(%$hashref)) {   if (&untie_domain_hash($hashref)) {
     chop($qresult);      chop($qresult);
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 3435  sub put_id_handler { Line 3522  sub put_id_handler {
     my ($key,$value)=split(/=/,$pair);      my ($key,$value)=split(/=/,$pair);
     $hashref->{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (untie(%$hashref)) {   if (&untie_domain_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 3484  sub get_id_handler { Line 3571  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(%$hashref)) {   if (&untie_domain_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 3501  sub get_id_handler { Line 3588  sub get_id_handler {
 &register_handler("idget", \&get_id_handler, 0, 1, 0);  &register_handler("idget", \&get_id_handler, 0, 1, 0);
   
 #  #
   # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database 
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose dcmail we are recording
   #               email    Consists of key=value pair 
   #                        where key is unique msgid
   #                        and value is message (in XML)
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply is written to $client.
   #
   sub put_dcmail_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
                                                                                   
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
       if ($hashref) {
           my ($key,$value)=split(/=/,$what);
           $hashref->{$key}=$value;
       }
       if (&untie_domain_hash($hashref)) {
           &Reply($client, "ok\n", $userinput);
       } else {
           &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                    "while attempting dcmailput\n", $userinput);
       }
       return 1;
   }
   &register_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0);
   
   #
   # Retrieves broadcast e-mail from nohist_dcmail database
   # Returns to client an & separated list of key=value pairs,
   # where key is msgid and value is message information.
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose dcmail table we dump
   #               startfilter - beginning of time window 
   #               endfilter - end of time window
   #               sendersfilter - & separated list of username:domain 
   #                 for senders to search for.
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply (& separated list of msgid=messageinfo pairs) is 
   #     written to $client.
   #
   sub dump_dcmail_handler {
       my ($cmd, $tail, $client) = @_;
                                                                                   
       my $userinput = "$cmd:$tail";
       my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail);
       chomp($sendersfilter);
       my @senders = ();
       if (defined($startfilter)) {
           $startfilter=&unescape($startfilter);
       } else {
           $startfilter='.';
       }
       if (defined($endfilter)) {
           $endfilter=&unescape($endfilter);
       } else {
           $endfilter='.';
       }
       if (defined($sendersfilter)) {
           $sendersfilter=&unescape($sendersfilter);
    @senders = map { &unescape($_) } split(/\&/,$sendersfilter);
       }
   
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
       if ($hashref) {
           while (my ($key,$value) = each(%$hashref)) {
               my $match = 1;
               my ($timestamp,$subj,$uname,$udom) = 
    split(/:/,&unescape(&unescape($key)),5); # yes, twice really
               $subj = &unescape($subj);
               unless ($startfilter eq '.' || !defined($startfilter)) {
                   if ($timestamp < $startfilter) {
                       $match = 0;
                   }
               }
               unless ($endfilter eq '.' || !defined($endfilter)) {
                   if ($timestamp > $endfilter) {
                       $match = 0;
                   }
               }
               unless (@senders < 1) {
                   unless (grep/^$uname:$udom$/,@senders) {
                       $match = 0;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$value.'&';
               }
           }
           if (&untie_domain_hash($hashref)) {
               chop($qresult);
               &Reply($client, "$qresult\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting dcmaildump\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting dcmaildump\n", $userinput);
       }
       return 1;
   }
   
   &register_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0);
   
   #
   # Puts domain roles in nohist_domainroles database
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose roles we are recording  
   #               role -   Consists of key=value pair
   #                        where key is unique role
   #                        and value is start/end date information
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply is written to $client.
   #
   
   sub put_domainroles_handler {
       my ($cmd,$tail,$client) = @_;
   
       my $userinput = "$cmd:$tail";
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
       if ($hashref) {
           foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               $hashref->{$key}=$value;
           }
           if (&untie_domain_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                        "while attempting domroleput\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting domroleput\n", $userinput);
       }
                                                                                     
       return 1;
   }
   
   &register_handler("domroleput", \&put_domainroles_handler, 0, 1, 0);
   
   #
   # Retrieves domain roles from nohist_domainroles database
   # Returns to client an & separated list of key=value pairs,
   # where key is role and value is start and end date information.
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose domain roles table we dump
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply (& separated list of role=start/end info pairs) is
   #     written to $client.
   #
   sub dump_domainroles_handler {
       my ($cmd, $tail, $client) = @_;
                                                                                              
       my $userinput = "$cmd:$tail";
       my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail);
       chomp($rolesfilter);
       my @roles = ();
       if (defined($startfilter)) {
           $startfilter=&unescape($startfilter);
       } else {
           $startfilter='.';
       }
       if (defined($endfilter)) {
           $endfilter=&unescape($endfilter);
       } else {
           $endfilter='.';
       }
       if (defined($rolesfilter)) {
           $rolesfilter=&unescape($rolesfilter);
    @roles = split(/\&/,$rolesfilter);
       }
                                                                                              
       my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
       if ($hashref) {
           my $qresult = '';
           while (my ($key,$value) = each(%$hashref)) {
               my $match = 1;
               my ($start,$end) = split(/:/,&unescape($value));
               my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
               unless ($startfilter eq '.' || !defined($startfilter)) {
                   if ($start >= $startfilter) {
                       $match = 0;
                   }
               }
               unless ($endfilter eq '.' || !defined($endfilter)) {
                   if ($end <= $endfilter) {
                       $match = 0;
                   }
               }
               unless (@roles < 1) {
                   unless (grep/^$trole$/,@roles) {
                       $match = 0;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$value.'&';
               }
           }
           if (&untie_domain_hash($hashref)) {
               chop($qresult);
               &Reply($client, "$qresult\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting domrolesdump\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting domrolesdump\n", $userinput);
       }
       return 1;
   }
   
   &register_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0);
   
   
 #  Process the tmpput command I'm not sure what this does.. Seems to  #  Process the tmpput command I'm not sure what this does.. Seems to
 #  create a file in the lonDaemons/tmp directory of the form $id.tmp  #  create a file in the lonDaemons/tmp directory of the form $id.tmp
 # where Id is the client's ip concatenated with a sequence number.  # where Id is the client's ip concatenated with a sequence number.
Line 3979  sub get_institutional_code_format_handle Line 4318  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 3991  sub get_institutional_code_format_handle Line 4407  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') {
    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) { &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 4404  sub ReadHostTable { Line 4832  sub ReadHostTable {
     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";      open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
     my $myloncapaname = $perlvar{'lonHostID'};      my $myloncapaname = $perlvar{'lonHostID'};
     Debug("My loncapa name is : $myloncapaname");      Debug("My loncapa name is : $myloncapaname");
       my %name_to_ip;
     while (my $configline=<CONFIG>) {      while (my $configline=<CONFIG>) {
  if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) {   if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) {
     my ($id,$domain,$role,$name)=split(/:/,$configline);      my ($id,$domain,$role,$name)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     my $ip = gethostbyname($name);      my $ip;
     if (length($ip) ne 4) {      if (!exists($name_to_ip{$name})) {
  &logthis("Skipping host $id name $name no IP $ip found\n");   $ip = gethostbyname($name);
  next;   if (!$ip || length($ip) ne 4) {
       &logthis("Skipping host $id name $name no IP found\n");
       next;
    }
    $ip=inet_ntoa($ip);
    $name_to_ip{$name} = $ip;
       } else {
    $ip = $name_to_ip{$name};
     }      }
     $ip=inet_ntoa($ip);  
     $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. 
     $hostip{$id}=$ip;         # IP address of host.      $hostip{$id}=$ip;         # IP address of host.
Line 4857  sub make_new_child { Line 5292  sub make_new_child {
 #        my $tmpsnum=0;            # Now global  #        my $tmpsnum=0;            # Now global
 #---------------------------------------------------- kerberos 5 initialization  #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
  if ($dist ne 'fedora4') {   unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) {
     &Authen::Krb5::init_ets();      &Authen::Krb5::init_ets();
  }   }
   
Line 5069  sub is_author { Line 5504  sub is_author {
 #    user      - Name of the user for which the role is being put.  #    user      - Name of the user for which the role is being put.
 #    authtype  - The authentication type associated with the user.  #    authtype  - The authentication type associated with the user.
 #  #
 sub manage_permissions  sub manage_permissions {
 {  
   
   
     my ($request, $domain, $user, $authtype) = @_;      my ($request, $domain, $user, $authtype) = @_;
   
     &Debug("manage_permissions: $request $domain $user $authtype");      &Debug("manage_permissions: $request $domain $user $authtype");
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};   my $execdir = $perlvar{'lonDaemons'};
  my $userhome= "/home/$user" ;   my $userhome= "/home/$user" ;
  &logthis("system $execdir/lchtmldir $userhome $user $authtype");   &logthis("system $execdir/lchtmldir $userhome $user $authtype");
Line 5327  sub addline { Line 5759  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=();
     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",      my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
     &GDBM_READER(),0640)) {   &GDBM_READER());
  @entries=map { $_.':'.$hash{$_} } sort keys %hash;      if ($hashref) {
  untie %hash;   @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
    &untie_user_hash($hashref);
     }      }
     my @participants=();      my @participants=();
     my $cutoff=time-60;      my $cutoff=time-60;
     if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",      $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',
     &GDBM_WRCREAT(),0640)) {        &GDBM_WRCREAT());
         $hash{$uname.':'.$udom}=time;      if ($hashref) {
         foreach (sort keys %hash) {          $hashref->{$uname.':'.$udom}=time;
     if ($hash{$_}>$cutoff) {          foreach my $user (sort(keys(%$hashref))) {
  $participants[$#participants+1]='active_participant:'.$_;      if ($hashref->{$user}>$cutoff) {
    push(@participants, 'active_participant:'.$user);
             }              }
         }          }
         untie %hash;          &untie_user_hash($hashref);
     }      }
     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;
     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",      my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
     &GDBM_WRCREAT(),0640)) {   &GDBM_WRCREAT());
  @entries=map { $_.':'.$hash{$_} } sort keys %hash;      if ($hashref) {
    @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 5368  sub chat_add { Line 5800  sub chat_add {
     $idnum=substr('000000'.$idnum,-6,6);      $idnum=substr('000000'.$idnum,-6,6);
     $newid=$time.'_'.$idnum;      $newid=$time.'_'.$idnum;
  }   }
  $hash{$newid}=$newchat;   $hashref->{$newid}=$newchat;
  my $expired=$time-3600;   my $expired=$time-3600;
  foreach (keys %hash) {   foreach my $comment (keys(%$hashref)) {
     my ($thistime)=($_=~/(\d+)\_/);      my ($thistime) = ($comment=~/(\d+)\_/);
     if ($thistime<$expired) {      if ($thistime<$expired) {
  delete $hash{$_};   delete $hashref->{$comment};
     }      }
  }   }
  untie %hash;   {
     }      my $proname=&propath($cdom,$cname);
     {      if (open(CHATLOG,">>$proname/chatroom.log")) { 
  my $hfh;   print CHATLOG ("$time:".&unescape($newchat)."\n");
  if ($hfh=IO::File->new(">>$proname/chatroom.log")) {       }
     print $hfh "$time:".&unescape($newchat)."\n";      close(CHATLOG);
  }   }
    &untie_user_hash($hashref);
     }      }
 }  }
   
Line 5471  sub thisversion { Line 5904  sub thisversion {
 sub subscribe {  sub subscribe {
     my ($userinput,$clientip)=@_;      my ($userinput,$clientip)=@_;
     my $result;      my $result;
     my ($cmd,$fname)=split(/:/,$userinput);      my ($cmd,$fname)=split(/:/,$userinput,2);
     my $ownership=&ishome($fname);      my $ownership=&ishome($fname);
     if ($ownership eq 'owner') {      if ($ownership eq 'owner') {
 # explitly asking for the current version?  # explitly asking for the current version?
Removed from v.1.287  
changed lines
  Added in v.1.305.2.4

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