Diff for /loncom/lond between versions 1.121 and 1.136

version 1.121, 2003/03/27 23:00:28 version 1.136, 2003/08/12 19:46:04
Line 50 Line 50
 #      population).  Since the time averaged connection rate is close to zero  #      population).  Since the time averaged connection rate is close to zero
 #      because lonc's purpose is to maintain near continuous connnections,  #      because lonc's purpose is to maintain near continuous connnections,
 #      preforking is not really needed.  #      preforking is not really needed.
   # 08/xx/2003 Ron Fox:  Add management requests.  Management requests
   #      will be validated via a call to ValidateManager. At present, this
   #      is done by simple host verification.  In the future we can modify
   #      this function to do a certificate check.
   #      Management functions supported include:
   #       - pushing /home/httpd/lonTabs/hosts.tab
   #       - pushing /home/httpd/lonTabs/domain.tab
 ###  ###
   
   use strict;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
 use Apache::File;  #use Apache::File;
 use Symbol;  use Symbol;
 use POSIX;  use POSIX;
 use Crypt::IDEA;  use Crypt::IDEA;
Line 77  my $VERSION='$Revision$'; #' stupid emac Line 85  my $VERSION='$Revision$'; #' stupid emac
 my $remoteVERSION;  my $remoteVERSION;
 my $currenthostid;  my $currenthostid;
 my $currentdomainid;  my $currentdomainid;
   
   my $client;
   my $server;
   my $thisserver;
   
   my %hostid;
   my %hostdom;
   my %hostip;
   
 #  #
 #  The array below are password error strings."  #  The array below are password error strings."
 #  #
Line 145  sub catchexception { Line 162  sub catchexception {
     $SIG{'QUIT'}='DEFAULT';      $SIG{'QUIT'}='DEFAULT';
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
     &logthis("<font color=red>CRITICAL: "      &logthis("<font color=red>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server $wasserver died through "       ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
      ."a crash with this error msg->[$error]</font>");       ."a crash with this error msg->[$error]</font>");
     &logthis('Famous last words: '.$status.' - '.$lastlog);      &logthis('Famous last words: '.$status.' - '.$lastlog);
     if ($client) { print $client "error: $error\n"; }      if ($client) { print $client "error: $error\n"; }
Line 171  undef $perlvarref; Line 188  undef $perlvarref;
 # ----------------------------- Make sure this process is running from user=www  # ----------------------------- Make sure this process is running from user=www
 my $wwwid=getpwnam('www');  my $wwwid=getpwnam('www');
 if ($wwwid!=$<) {  if ($wwwid!=$<) {
    $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";     my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
    $subj="LON: $currenthostid User ID mismatch";     my $subj="LON: $currenthostid User ID mismatch";
    system("echo 'User ID mismatch.  lond must be run as user www.' |\     system("echo 'User ID mismatch.  lond must be run as user www.' |\
  mailto $emailto -s '$subj' > /dev/null");   mailto $emailto -s '$subj' > /dev/null");
    exit 1;     exit 1;
Line 189  if (-e $pidfile) { Line 206  if (-e $pidfile) {
    if (kill 0 => $pide) { die "already running"; }     if (kill 0 => $pide) { die "already running"; }
 }  }
   
 $PREFORK=4; # number of children to maintain, at least four spare  
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
   
 open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";  open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
   
 while ($configline=<CONFIG>) {  while (my $configline=<CONFIG>) {
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
     chomp($ip); $ip=~s/\D+$//;      chomp($ip); $ip=~s/\D+$//;
     $hostid{$ip}=$id;      $hostid{$ip}=$id;
     $hostdom{$id}=$domain;      $hostdom{$id}=$domain;
     $hostip{$id}=$ip;      $hostip{$id}=$ip;
     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }      if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
     $PREFORK++;  
 }  }
 close(CONFIG);  close(CONFIG);
   
Line 218  $server = IO::Socket::INET->new(LocalPor Line 232  $server = IO::Socket::INET->new(LocalPor
   
 # global variables  # global variables
   
 $MAX_CLIENTS_PER_CHILD  = 50;        # number of clients each child should   my %children               = ();       # keys are current child process IDs
                                     # process  my $children               = 0;        # current number of children
 %children               = ();       # keys are current child process IDs  
 $children               = 0;        # current number of children  
   
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
Line 250  sub HUPSMAN {                      # sig Line 262  sub HUPSMAN {                      # sig
     kill 'INT' => keys %children;      kill 'INT' => keys %children;
     &logthis("Free socket: ".shutdown($server,2)); # free up socket      &logthis("Free socket: ".shutdown($server,2)); # free up socket
     &logthis("<font color=red>CRITICAL: Restarting</font>");      &logthis("<font color=red>CRITICAL: Restarting</font>");
     unlink("$execdir/logs/lond.pid");  
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
       unlink("$execdir/logs/lond.pid");
     exec("$execdir/lond");         # here we go again      exec("$execdir/lond");         # here we go again
 }  }
   
Line 259  sub checkchildren { Line 271  sub checkchildren {
     &initnewstatus();      &initnewstatus();
     &logstatus();      &logstatus();
     &logthis('Going to check on the children');      &logthis('Going to check on the children');
     $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
     foreach (sort keys %children) {      foreach (sort keys %children) {
  sleep 1;   sleep 1;
         unless (kill 'USR1' => $_) {          unless (kill 'USR1' => $_) {
Line 276  sub checkchildren { Line 288  sub checkchildren {
             alarm(300);              alarm(300);
     &logthis('Child '.$_.' did not respond');      &logthis('Child '.$_.' did not respond');
     kill 9 => $_;      kill 9 => $_;
     $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";      #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
     $subj="LON: $currenthostid killed lond process $_";      #$subj="LON: $currenthostid killed lond process $_";
     my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;      #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
     $execdir=$perlvar{'lonDaemons'};      #$execdir=$perlvar{'lonDaemons'};
     $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;      #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
     alarm(0);      alarm(0);
   }    }
         }          }
Line 331  sub initnewstatus { Line 343  sub initnewstatus {
     my $local=localtime($now);      my $local=localtime($now);
     print $fh "LOND status $local - parent $$\n\n";      print $fh "LOND status $local - parent $$\n\n";
     opendir(DIR,"$docdir/lon-status/londchld");      opendir(DIR,"$docdir/lon-status/londchld");
     while ($filename=readdir(DIR)) {      while (my $filename=readdir(DIR)) {
         unlink("$docdir/lon-status/londchld/$filename");          unlink("$docdir/lon-status/londchld/$filename");
     }      }
     closedir(DIR);      closedir(DIR);
Line 375  sub reconlonc { Line 387  sub reconlonc {
         if (kill 0 => $loncpid) {          if (kill 0 => $loncpid) {
     &logthis("lonc at pid $loncpid responding, sending USR1");      &logthis("lonc at pid $loncpid responding, sending USR1");
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
             sleep 5;  
             if (-e "$peerfile") { return; }  
             &logthis("$peerfile still not there, give it another try");  
             sleep 10;  
             if (-e "$peerfile") { return; }  
             &logthis(  
  "<font color=blue>WARNING: $peerfile still not there, giving up</font>");  
         } else {          } else {
     &logthis(      &logthis(
               "<font color=red>CRITICAL: "                "<font color=red>CRITICAL: "
Line 480  sub ishome { Line 485  sub ishome {
 # ======================================================= Continue main program  # ======================================================= Continue main program
 # ---------------------------------------------------- Fork once and dissociate  # ---------------------------------------------------- Fork once and dissociate
   
 $fpid=fork;  my $fpid=fork;
 exit if $fpid;  exit if $fpid;
 die "Couldn't fork: $!" unless defined ($fpid);  die "Couldn't fork: $!" unless defined ($fpid);
   
Line 488  POSIX::setsid() or die "Can't start new Line 493  POSIX::setsid() or die "Can't start new
   
 # ------------------------------------------------------- Write our PID on disk  # ------------------------------------------------------- Write our PID on disk
   
 $execdir=$perlvar{'lonDaemons'};  my $execdir=$perlvar{'lonDaemons'};
 open (PIDSAVE,">$execdir/logs/lond.pid");  open (PIDSAVE,">$execdir/logs/lond.pid");
 print PIDSAVE "$$\n";  print PIDSAVE "$$\n";
 close(PIDSAVE);  close(PIDSAVE);
Line 518  while (1) { Line 523  while (1) {
 }  }
   
 sub make_new_child {  sub make_new_child {
     my $client;  
     my $pid;      my $pid;
     my $cipher;      my $cipher;
     my $sigset;      my $sigset;
Line 529  sub make_new_child { Line 533  sub make_new_child {
     $sigset = POSIX::SigSet->new(SIGINT);      $sigset = POSIX::SigSet->new(SIGINT);
     sigprocmask(SIG_BLOCK, $sigset)      sigprocmask(SIG_BLOCK, $sigset)
         or die "Can't block SIGINT for fork: $!\n";          or die "Can't block SIGINT for fork: $!\n";
       
       my $clientip;
     die "fork: $!" unless defined ($pid = fork);      die "fork: $!" unless defined ($pid = fork);
           
     if ($pid) {      if ($pid) {
Line 543  sub make_new_child { Line 548  sub make_new_child {
     } else {      } else {
         # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before          $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
           $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns 
                                   #don't get intercepted
         $SIG{USR1}= \&logstatus;          $SIG{USR1}= \&logstatus;
         $SIG{ALRM}= \&timeout;          $SIG{ALRM}= \&timeout;
         $lastlog='Forked ';          $lastlog='Forked ';
Line 552  sub make_new_child { Line 559  sub make_new_child {
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
   
         $tmpsnum=0;          my $tmpsnum=0;
 #---------------------------------------------------- kerberos 5 initialization  #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
         &Authen::Krb5::init_ets();          &Authen::Krb5::init_ets();
Line 566  sub make_new_child { Line 573  sub make_new_child {
             # see if we know client and check for spoof IP by challenge              # see if we know client and check for spoof IP by challenge
  my $caller = getpeername($client);   my $caller = getpeername($client);
             my ($port,$iaddr)=unpack_sockaddr_in($caller);              my ($port,$iaddr)=unpack_sockaddr_in($caller);
             my $clientip=inet_ntoa($iaddr);              $clientip=inet_ntoa($iaddr);
             my $clientrec=($hostid{$clientip} ne undef);              my $clientrec=($hostid{$clientip} ne undef);
             &logthis(              &logthis(
 "<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"  "<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
Line 646  sub make_new_child { Line 653  sub make_new_child {
                        print $client "$currenthostid\n";                         print $client "$currenthostid\n";
 # ------------------------------------------------------------------------ pong  # ------------------------------------------------------------------------ pong
    } elsif ($userinput =~ /^pong/) {     } elsif ($userinput =~ /^pong/) {
                        $reply=reply("ping",$hostid{$clientip});                         my $reply=&reply("ping",$hostid{$clientip});
                        print $client "$currenthostid:$reply\n";                          print $client "$currenthostid:$reply\n"; 
 # ------------------------------------------------------------------------ ekey  # ------------------------------------------------------------------------ ekey
    } elsif ($userinput =~ /^ekey/) {     } elsif ($userinput =~ /^ekey/) {
Line 670  sub make_new_child { Line 677  sub make_new_child {
                           $loadavg=<$loadfile>;                            $loadavg=<$loadfile>;
                        }                         }
                        $loadavg =~ s/\s.*//g;                         $loadavg =~ s/\s.*//g;
                        my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};         my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
        print $client "$loadpercent\n";         print $client "$loadpercent\n";
   # -------------------------------------------------------------------- userload
      } elsif ($userinput =~ /^userload/) {
          my $userloadpercent=&userload();
          print $client "$userloadpercent\n";
 # ----------------------------------------------------------------- currentauth  # ----------------------------------------------------------------- currentauth
    } elsif ($userinput =~ /^currentauth/) {     } elsif ($userinput =~ /^currentauth/) {
      if ($wasenc==1) {       if ($wasenc==1) {
Line 726  sub make_new_child { Line 737  sub make_new_child {
       }        }
       }        }
                           } elsif ($howpwd eq 'krb4') {                            } elsif ($howpwd eq 'krb4') {
                               $null=pack("C",0);                                my $null=pack("C",0);
                               unless ($upass=~/$null/) {                                unless ($upass=~/$null/) {
                                   my $krb4_error = &Authen::Krb4::get_pw_in_tkt                                    my $krb4_error = &Authen::Krb4::get_pw_in_tkt
                                       ($uname,"",$contentpwd,'krbtgt',                                        ($uname,"",$contentpwd,'krbtgt',
Line 743  sub make_new_child { Line 754  sub make_new_child {
                                   }                                    }
                               }                                }
                           } elsif ($howpwd eq 'krb5') {                            } elsif ($howpwd eq 'krb5') {
       $null=pack("C",0);        my $null=pack("C",0);
       unless ($upass=~/$null/) {        unless ($upass=~/$null/) {
   my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);    my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
   my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;    my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
Line 827  sub make_new_child { Line 838  sub make_new_child {
      if ($pwdcorrect) {       if ($pwdcorrect) {
  my $execdir=$perlvar{'lonDaemons'};   my $execdir=$perlvar{'lonDaemons'};
  &Debug("Opening lcpasswd pipeline");   &Debug("Opening lcpasswd pipeline");
  my $pf = IO::File->new("|$execdir/lcpasswd > /home/www/lcpasswd.log");   my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
  print $pf "$uname\n$npass\n$npass\n";   print $pf "$uname\n$npass\n$npass\n";
  close $pf;   close $pf;
  my $err = $?;   my $err = $?;
Line 868  sub make_new_child { Line 879  sub make_new_child {
                        } elsif ($udom ne $currentdomainid) {                         } elsif ($udom ne $currentdomainid) {
                            print $client "not_right_domain\n";                             print $client "not_right_domain\n";
                        } else {                         } else {
                            @fpparts=split(/\//,$proname);                             my @fpparts=split(/\//,$proname);
                            $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];                             my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
                            $fperror='';                             my $fperror='';
                            for ($i=3;$i<=$#fpparts;$i++) {                             for (my $i=3;$i<=$#fpparts;$i++) {
                                $fpnow.='/'.$fpparts[$i];                                  $fpnow.='/'.$fpparts[$i]; 
                                unless (-e $fpnow) {                                 unless (-e $fpnow) {
    unless (mkdir($fpnow,0777)) {     unless (mkdir($fpnow,0777)) {
Line 935  sub make_new_child { Line 946  sub make_new_child {
                               $uid,$gid,$rdev,$size,                                $uid,$gid,$rdev,$size,
                               $atime,$mtime,$ctime,                                $atime,$mtime,$ctime,
                               $blksize,$blocks)=stat($fname);                                $blksize,$blocks)=stat($fname);
                           $now=time;                            my $now=time;
                           $since=$now-$atime;                            my $since=$now-$atime;
                           if ($since>$perlvar{'lonExpire'}) {                            if ($since>$perlvar{'lonExpire'}) {
                               $reply=                                my $reply=
                                     reply("unsub:$fname","$hostid{$clientip}");                                      &reply("unsub:$fname","$hostid{$clientip}");
                               unlink("$fname");                                unlink("$fname");
                           } else {                            } else {
      my $transname="$fname.in.transfer";       my $transname="$fname.in.transfer";
Line 1010  sub make_new_child { Line 1021  sub make_new_child {
                    } elsif ($userinput =~ /^tokenauthuserfile/) {                     } elsif ($userinput =~ /^tokenauthuserfile/) {
                        my ($cmd,$fname,$session)=split(/:/,$userinput);                         my ($cmd,$fname,$session)=split(/:/,$userinput);
                        chomp($session);                         chomp($session);
                        $reply='non_auth';                         my $reply='non_auth';
                        if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.                         if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
                                       $session.'.id')) {   $session.'.id')) {
                         while ($line=<ENVIN>) {     while (my $line=<ENVIN>) {
    if ($line=~/userfile\.$fname\=/) { $reply='ok'; }         if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
                         }     }
                         close(ENVIN);     close(ENVIN);
                         print $client $reply."\n";     print $client $reply."\n";
        } else {         } else {
  print $client "invalid_token\n";     print $client "invalid_token\n";
                        }                         }
 # ----------------------------------------------------------------- unsubscribe  # ----------------------------------------------------------------- unsubscribe
                    } elsif ($userinput =~ /^unsub/) {                     } elsif ($userinput =~ /^unsub/) {
Line 1070  sub make_new_child { Line 1081  sub make_new_child {
        ) { print $hfh "P:$now:$what\n"; }         ) { print $hfh "P:$now:$what\n"; }
        }         }
                        my @pairs=split(/\&/,$what);                         my @pairs=split(/\&/,$what);
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {         my %hash;
                            foreach $pair (@pairs) {         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
        ($key,$value)=split(/=/,$pair);                             foreach my $pair (@pairs) {
          my ($key,$value)=split(/=/,$pair);
                                $hash{$key}=$value;                                 $hash{$key}=$value;
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
Line 1112  sub make_new_child { Line 1124  sub make_new_child {
                                  }                                   }
        }         }
                        my @pairs=split(/\&/,$what);                         my @pairs=split(/\&/,$what);
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {         my %hash;
                            foreach $pair (@pairs) {         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
        ($key,$value)=split(/=/,$pair);                             foreach my $pair (@pairs) {
          my ($key,$value)=split(/=/,$pair);
        &ManagePermissions($key, $udom, $uname,         &ManagePermissions($key, $udom, $uname,
   &GetAuthType( $udom,     &GetAuthType( $udom, 
  $uname));   $uname));
                                $hash{$key}=$value;                                 $hash{$key}=$value;
          
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
                               print $client "ok\n";                                print $client "ok\n";
Line 1158  sub make_new_child { Line 1170  sub make_new_child {
                                  }                                   }
        }         }
                        my @rolekeys=split(/\&/,$what);                         my @rolekeys=split(/\&/,$what);
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {         my %hash;
                            foreach $key (@rolekeys) {         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
                              foreach my $key (@rolekeys) {
                                delete $hash{$key};                                 delete $hash{$key};
          
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
                               print $client "ok\n";                                print $client "ok\n";
Line 1188  sub make_new_child { Line 1200  sub make_new_child {
                        my @queries=split(/\&/,$what);                         my @queries=split(/\&/,$what);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {         my %hash;
                            for ($i=0;$i<=$#queries;$i++) {         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
                              for (my $i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";                                 $qresult.="$hash{$queries[$i]}&";
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
Line 1220  sub make_new_child { Line 1233  sub make_new_child {
                        my @queries=split(/\&/,$what);                         my @queries=split(/\&/,$what);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {         my %hash;
                            for ($i=0;$i<=$#queries;$i++) {         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
                              for (my $i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";                                 $qresult.="$hash{$queries[$i]}&";
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
Line 1266  sub make_new_child { Line 1280  sub make_new_child {
        ) { print $hfh "D:$now:$what\n"; }         ) { print $hfh "D:$now:$what\n"; }
        }         }
                        my @keys=split(/\&/,$what);                         my @keys=split(/\&/,$what);
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {         my %hash;
                            foreach $key (@keys) {         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
                              foreach my $key (@keys) {
                                delete($hash{$key});                                 delete($hash{$key});
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
Line 1290  sub make_new_child { Line 1305  sub make_new_child {
                        $namespace=~s/\W//g;                         $namespace=~s/\W//g;
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {         my %hash;
                            foreach $key (keys %hash) {         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
                              foreach my $key (keys %hash) {
                                $qresult.="$key&";                                 $qresult.="$key&";
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
Line 1315  sub make_new_child { Line 1331  sub make_new_child {
                        $namespace=~s/\W//g;                         $namespace=~s/\W//g;
                        my $qresult='';                         my $qresult='';
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
          my %hash;
                        if (tie(%hash,'GDBM_File',                         if (tie(%hash,'GDBM_File',
                                "$proname/$namespace.db",                                 "$proname/$namespace.db",
                                &GDBM_READER(),0640)) {                                 &GDBM_READER(),0640)) {
Line 1365  sub make_new_child { Line 1382  sub make_new_child {
        }         }
                        my $qresult='';                         my $qresult='';
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {         my %hash;
          if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
                            study($regexp);                             study($regexp);
                            while (($key,$value) = each(%hash)) {                             while (my ($key,$value) = each(%hash)) {
                                if ($regexp eq '.') {                                 if ($regexp eq '.') {
                                    $qresult.=$key.'='.$value.'&';                                     $qresult.=$key.'='.$value.'&';
                                } else {                                 } else {
Line 1407  sub make_new_child { Line 1425  sub make_new_child {
        ) { print $hfh "P:$now:$rid:$what\n"; }         ) { print $hfh "P:$now:$rid:$what\n"; }
        }         }
                        my @pairs=split(/\&/,$what);                         my @pairs=split(/\&/,$what);
                                   my %hash;
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
                            my @previouskeys=split(/&/,$hash{"keys:$rid"});                             my @previouskeys=split(/&/,$hash{"keys:$rid"});
                            my $key;                             my $key;
                            $hash{"version:$rid"}++;                             $hash{"version:$rid"}++;
                            my $version=$hash{"version:$rid"};                             my $version=$hash{"version:$rid"};
                            my $allkeys='';                              my $allkeys=''; 
                            foreach $pair (@pairs) {                             foreach my $pair (@pairs) {
        ($key,$value)=split(/=/,$pair);         my ($key,$value)=split(/=/,$pair);
                                $allkeys.=$key.':';                                 $allkeys.=$key.':';
                                $hash{"$version:$rid:$key"}=$value;                                 $hash{"$version:$rid:$key"}=$value;
                            }                             }
Line 1446  sub make_new_child { Line 1464  sub make_new_child {
                        chomp($rid);                         chomp($rid);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {         my %hash;
          if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
                   my $version=$hash{"version:$rid"};                    my $version=$hash{"version:$rid"};
                            $qresult.="version=$version&";                             $qresult.="version=$version&";
                            my $scope;                             my $scope;
Line 1479  sub make_new_child { Line 1498  sub make_new_child {
                        print $client "ok\n";                         print $client "ok\n";
 # -------------------------------------------------------------------- chatretr  # -------------------------------------------------------------------- chatretr
                    } elsif ($userinput =~ /^chatretr/) {                     } elsif ($userinput =~ /^chatretr/) {
                        my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);                         my 
                           ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
                        my $reply='';                         my $reply='';
                        foreach (&getchat($cdom,$cnum)) {                         foreach (&getchat($cdom,$cnum,$udom,$uname)) {
    $reply.=&escape($_).':';     $reply.=&escape($_).':';
                        }                         }
                        $reply=~s/\:$//;                         $reply=~s/\:$//;
Line 1522  sub make_new_child { Line 1542  sub make_new_child {
                               "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";                                "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
                        my $now=time;                         my $now=time;
                        my @pairs=split(/\&/,$what);                         my @pairs=split(/\&/,$what);
                  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {         my %hash;
                            foreach $pair (@pairs) {         if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
        ($key,$value)=split(/=/,$pair);                             foreach my $pair (@pairs) {
          my ($key,$value)=split(/=/,$pair);
                                $hash{$key}=$value.':'.$now;                                 $hash{$key}=$value.':'.$now;
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
Line 1552  sub make_new_child { Line 1573  sub make_new_child {
                        my $qresult='';                         my $qresult='';
                        my $proname=                         my $proname=
                               "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";                                "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
                 if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {         my %hash;
                            while (($key,$value) = each(%hash)) {         if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
                              while (my ($key,$value) = each(%hash)) {
                                my ($descr,$lasttime)=split(/\:/,$value);                                 my ($descr,$lasttime)=split(/\:/,$value);
                                if ($lasttime<$since) { next; }                                 if ($lasttime<$since) { next; }
                                if ($regexp eq '.') {                                 if ($description eq '.') {
                                    $qresult.=$key.'='.$descr.'&';                                     $qresult.=$key.'='.$descr.'&';
                                } else {                                 } else {
                                    my $unescapeVal = &unescape($descr);                                     my $unescapeVal = &unescape($descr);
Line 1592  sub make_new_child { Line 1614  sub make_new_child {
        ) { print $hfh "P:$now:$what\n"; }         ) { print $hfh "P:$now:$what\n"; }
        }         }
                        my @pairs=split(/\&/,$what);                         my @pairs=split(/\&/,$what);
                  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {         my %hash;
                            foreach $pair (@pairs) {         if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
        ($key,$value)=split(/=/,$pair);                             foreach my $pair (@pairs) {
          my ($key,$value)=split(/=/,$pair);
                                $hash{$key}=$value;                                 $hash{$key}=$value;
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
Line 1617  sub make_new_child { Line 1640  sub make_new_child {
                        my $proname="$perlvar{'lonUsersDir'}/$udom/ids";                         my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
                        my @queries=split(/\&/,$what);                         my @queries=split(/\&/,$what);
                        my $qresult='';                         my $qresult='';
                  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {         my %hash;
                            for ($i=0;$i<=$#queries;$i++) {         if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
                              for (my $i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";                                 $qresult.="$hash{$queries[$i]}&";
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
               $qresult=~s/\&$//;         $qresult=~s/\&$//;
                               print $client "$qresult\n";         print $client "$qresult\n";
                            } else {                             } else {
                               print $client "error: ".($!+0)         print $client "error: ".($!+0)
   ." untie(GDBM) Failed ".     ." untie(GDBM) Failed ".
                                       "while attempting idget\n";         "while attempting idget\n";
                            }                             }
                        } else {                         } else {
                            print $client "error: ".($!+0)                             print $client "error: ".($!+0)
Line 1709  sub make_new_child { Line 1733  sub make_new_child {
                        }                         }
                        if ($ulsout eq '') { $ulsout='empty'; }                         if ($ulsout eq '') { $ulsout='empty'; }
                        print $client "$ulsout\n";                         print $client "$ulsout\n";
   # ----------------------------------------------------------------- setannounce
                      } elsif ($userinput =~ /^setannounce/) {
          my ($cmd,$announcement)=split(/:/,$userinput);
          chomp($announcement);
          $announcement=&unescape($announcement);
                          if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
    '/announcement.txt')) {
      print $store $announcement;
                              close $store;
      print $client "ok\n";
          } else {
      print $client "error: ".($!+0)."\n";
          }
 # ------------------------------------------------------------------ Hanging up  # ------------------------------------------------------------------ Hanging up
                    } elsif (($userinput =~ /^exit/) ||                     } elsif (($userinput =~ /^exit/) ||
                             ($userinput =~ /^init/)) {                              ($userinput =~ /^init/)) {
Line 1772  sub ManagePermissions Line 1809  sub ManagePermissions
     my $authtype= shift;      my $authtype= shift;
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
       &logthis("ruequest is $request");
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};   my $execdir = $perlvar{'lonDaemons'};
  my $userhome= "/home/$user" ;   my $userhome= "/home/$user" ;
  Debug("system $execdir/lchtmldir $userhome $system $authtype");   &logthis("system $execdir/lchtmldir $userhome $user $authtype");
  system("$execdir/lchtmldir $userhome $user $authtype");   system("$execdir/lchtmldir $userhome $user $authtype");
     }      }
 }  }
Line 1819  sub addline { Line 1856  sub addline {
     my $found=0;      my $found=0;
     my $expr='^'.$hostid.':'.$ip.':';      my $expr='^'.$hostid.':'.$ip.':';
     $expr =~ s/\./\\\./g;      $expr =~ s/\./\\\./g;
       my $sh;
     if ($sh=IO::File->new("$fname.subscription")) {      if ($sh=IO::File->new("$fname.subscription")) {
  while (my $subline=<$sh>) {   while (my $subline=<$sh>) {
     if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}      if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
Line 1833  sub addline { Line 1871  sub addline {
 }  }
   
 sub getchat {  sub getchat {
     my ($cdom,$cname)=@_;      my ($cdom,$cname,$udom,$uname)=@_;
     my %hash;      my %hash;
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
     my @entries=();      my @entries=();
Line 1842  sub getchat { Line 1880  sub getchat {
  @entries=map { $_.':'.$hash{$_} } sort keys %hash;   @entries=map { $_.':'.$hash{$_} } sort keys %hash;
  untie %hash;   untie %hash;
     }      }
     return @entries;      my @participants=();
       my $cutoff=time-60;
       if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
       &GDBM_WRCREAT(),0640)) {
           $hash{$uname.':'.$udom}=time;
           foreach (sort keys %hash) {
       if ($hash{$_}>$cutoff) {
    $participants[$#participants+1]='active_participant:'.$_;
               }
           }
           untie %hash;
       }
       return (@participants,@entries);
 }  }
   
 sub chatadd {  sub chatadd {
Line 1909  sub currentversion { Line 1959  sub currentversion {
     }      }
     if (-e $fname) { $version=1; }      if (-e $fname) { $version=1; }
     if (-e $ulsdir) {      if (-e $ulsdir) {
        if(-d $ulsdir) {   if(-d $ulsdir) {
           if (opendir(LSDIR,$ulsdir)) {      if (opendir(LSDIR,$ulsdir)) {
    my $ulsfn;
              while ($ulsfn=readdir(LSDIR)) {   while ($ulsfn=readdir(LSDIR)) {
 # see if this is a regular file (ignore links produced earlier)  # see if this is a regular file (ignore links produced earlier)
                  my $thisfile=$ulsdir.'/'.$ulsfn;      my $thisfile=$ulsdir.'/'.$ulsfn;
                  unless (-l $thisfile) {      unless (-l $thisfile) {
      if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {   if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
  if ($1>$version) { $version=$1; }      if ($1>$version) { $version=$1; }
      }   }
  }      }
              }   }
              closedir(LSDIR);   closedir(LSDIR);
              $version++;   $version++;
           }      }
       }   }
    }      }
    return $version;      return $version;
 }  }
   
 sub thisversion {  sub thisversion {
Line 1965  sub subscribe { Line 2015  sub subscribe {
  $result="directory\n";   $result="directory\n";
     } else {      } else {
  if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}   if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
  $now=time;   my $now=time;
  my $found=&addline($fname,$hostid{$clientip},$clientip,   my $found=&addline($fname,$hostid{$clientip},$clientip,
    "$hostid{$clientip}:$clientip:$now\n");     "$hostid{$clientip}:$clientip:$now\n");
  if ($found) { $result="$fname\n"; }   if ($found) { $result="$fname\n"; }
Line 2014  sub make_passwd_file { Line 2064  sub make_passwd_file {
     {      {
  &Debug("Executing external: ".$execpath);   &Debug("Executing external: ".$execpath);
  &Debug("user  = ".$uname.", Password =". $npass);   &Debug("user  = ".$uname.", Password =". $npass);
  my $se = IO::File->new("|$execpath > /home/www/lcuseradd.log");   my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
  print $se "$uname\n";   print $se "$uname\n";
  print $se "$npass\n";   print $se "$npass\n";
  print $se "$npass\n";   print $se "$npass\n";
Line 2059  sub version { Line 2109  sub version {
     return "version:$VERSION";      return "version:$VERSION";
 }  }
   
   #There is a copy of this in lonnet.pm
   sub userload {
       my $numusers=0;
       {
    opendir(LONIDS,$perlvar{'lonIDsDir'});
    my $filename;
    my $curtime=time;
    while ($filename=readdir(LONIDS)) {
       if ($filename eq '.' || $filename eq '..') {next;}
       my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
       if ($curtime-$atime < 3600) { $numusers++; }
    }
    closedir(LONIDS);
       }
       my $userloadpercent=0;
       my $maxuserload=$perlvar{'lonUserLoadLim'};
       if ($maxuserload) {
    $userloadpercent=100*$numusers/$maxuserload;
       }
       $userloadpercent=sprintf("%.2f",$userloadpercent);
       return $userloadpercent;
   }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
 =head1 NAME  =head1 NAME
Line 2328  Send along temporarily stored informatio Line 2401  Send along temporarily stored informatio
   
 List part of a user's directory.  List part of a user's directory.
   
   =item pushtable
   
   Pushes a file in /home/httpd/lonTab directory.  Currently limited to:
   hosts.tab and domain.tab. The old file is copied to  *.tab.backup but
   must be restored manually in case of a problem with the new table file.
   pushtable requires that the request be encrypted and validated via
   ValidateManager.  The form of the command is:
   enc:pushtable tablename <tablecontents> \n
   where pushtable, tablename and <tablecontents> will be encrypted, but \n is a 
   cleartext newline.
   
 =item Hanging up (exit or init)  =item Hanging up (exit or init)
   
 What to do when a client tells the server that they (the client)  What to do when a client tells the server that they (the client)
Line 2338  are leaving the network. Line 2422  are leaving the network.
 If B<lond> is sent an unknown command (not in the list above),  If B<lond> is sent an unknown command (not in the list above),
 it replys to the client "unknown_cmd".  it replys to the client "unknown_cmd".
   
   
 =item UNKNOWN CLIENT  =item UNKNOWN CLIENT
   
 If the anti-spoofing algorithm cannot verify the client,  If the anti-spoofing algorithm cannot verify the client,

Removed from v.1.121  
changed lines
  Added in v.1.136


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