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

Diff for /loncom/lond between versions 1.3 and 1.20

version 1.3, 1999/11/04 20:12:47 version 1.20, 2000/09/18 14:57:43
Line 3 Line 3
 # lond "LON Daemon" Server (port "LOND" 5663)  # lond "LON Daemon" Server (port "LOND" 5663)
 # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,  # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,
 # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,  # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,
 # 10/7,10/8,10/9,10/11,10/13,10/15 Gerd Kortemeyer  # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
   # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
   # 03/07,05/31 Gerd Kortemeyer
   # 06/26 Scott Harrison
   # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
   #
 # based on "Perl Cookbook" ISBN 1-56592-243-3  # based on "Perl Cookbook" ISBN 1-56592-243-3
 # preforker - server who forks first  # preforker - server who forks first
 # runs as a daemon  # runs as a daemon
Line 27  open (CONFIG,"/etc/httpd/conf/access.con Line 32  open (CONFIG,"/etc/httpd/conf/access.con
 while ($configline=<CONFIG>) {  while ($configline=<CONFIG>) {
     if ($configline =~ /PerlSetVar/) {      if ($configline =~ /PerlSetVar/) {
  my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
           chomp($varvalue);
         $perlvar{$varname}=$varvalue;          $perlvar{$varname}=$varvalue;
     }      }
 }  }
 close(CONFIG);  close(CONFIG);
   
   # --------------------------------------------- Check if other instance running
   
   my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
   
   if (-e $pidfile) {
      my $lfh=IO::File->new("$pidfile");
      my $pide=<$lfh>;
      chomp($pide);
      if (kill 0 => $pide) { die "already running"; }
   }
   
 $PREFORK=4; # number of children to maintain, at least four spare  $PREFORK=4; # number of children to maintain, at least four spare
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
Line 77  sub HUNTSMAN {                      # si Line 94  sub HUNTSMAN {                      # si
     kill 'INT' => keys %children;      kill 'INT' => keys %children;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lond.pid");      unlink("$execdir/logs/lond.pid");
     &logthis("Shutting down");      &logthis("<font color=red>CRITICAL: Shutting down</font>");
     exit;                           # clean up with dignity      exit;                           # clean up with dignity
 }  }
   
Line 85  sub HUPSMAN {                      # sig Line 102  sub HUPSMAN {                      # sig
     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children      local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
     kill 'INT' => keys %children;      kill 'INT' => keys %children;
     close($server);                # free up socket      close($server);                # free up socket
     &logthis("Restarting");      &logthis("<font color=red>CRITICAL: Restarting</font>");
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     exec("$execdir/lond");         # here we go again      exec("$execdir/lond");         # here we go again
 }  }
Line 101  sub logthis { Line 118  sub logthis {
     print $fh "$local ($$): $message\n";      print $fh "$local ($$): $message\n";
 }  }
   
   
   # -------------------------------------------------------- Escape Special Chars
   
   sub escape {
       my $str=shift;
       $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
       return $str;
   }
   
   # ----------------------------------------------------- Un-Escape Special Chars
   
   sub unescape {
       my $str=shift;
       $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
       return $str;
   }
   
 # ----------------------------------------------------------- Send USR1 to lonc  # ----------------------------------------------------------- Send USR1 to lonc
   
 sub reconlonc {  sub reconlonc {
Line 118  sub reconlonc { Line 152  sub reconlonc {
             &logthis("$peerfile still not there, give it another try");              &logthis("$peerfile still not there, give it another try");
             sleep 5;              sleep 5;
             if (-e "$peerfile") { return; }              if (-e "$peerfile") { return; }
             &logthis("$peerfile still not there, giving up");              &logthis(
    "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
         } else {          } else {
     &logthis("lonc at pid $loncpid not responding, giving up");      &logthis(
                 "<font color=red>CRITICAL: "
                ."lonc at pid $loncpid not responding, giving up</font>");
         }          }
     } else {      } else {
         &logthis('lonc not running, giving up');        &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
     }      }
 }  }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
   
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/$server";
Line 160  sub reply { Line 198  sub reply {
   return $answer;    return $answer;
 }  }
   
   # -------------------------------------------------------------- Talk to lonsql
   
   sub sqlreply {
       my ($cmd)=@_;
       my $answer=subsqlreply($cmd);
       if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
       return $answer;
   }
   
   sub subsqlreply {
       my ($cmd)=@_;
       my $unixsock="mysqlsock";
       my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
       my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                         Type    => SOCK_STREAM,
                                         Timeout => 10)
          or return "con_lost";
       print $sclient "$cmd\n";
       my $answer=<$sclient>;
       chomp($answer);
       if (!$answer) { $answer="con_lost"; }
       return $answer;
   }
   
 # -------------------------------------------- Return path to profile directory  # -------------------------------------------- Return path to profile directory
   
 sub propath {  sub propath {
     my ($udom,$uname)=@_;      my ($udom,$uname)=@_;
     $udom=~s/\W//g;      $udom=~s/\W//g;
     $uname=~s/\W//g;      $uname=~s/\W//g;
     my $subdir=$uname;      my $subdir=$uname.'__';
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";      my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
     return $proname;      return $proname;
 }   } 
   
 # --------------------------------------- Is this the home server of an author?  # --------------------------------------- Is this the home server of an author?
   
 sub ishome {  sub ishome {
     my $author=shift;      my $author=shift;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
Line 199  $execdir=$perlvar{'lonDaemons'}; Line 263  $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);
 &logthis("Starting");  &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
   
 # ------------------------------------------------------- Now we are on our own  # ------------------------------------------------------- Now we are on our own
           
Line 248  sub make_new_child { Line 312  sub make_new_child {
         # unblock signals          # unblock signals
         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;
           
         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD          # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
         for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {          for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
Line 261  sub make_new_child { Line 327  sub make_new_child {
             my ($port,$iaddr)=unpack_sockaddr_in($caller);              my ($port,$iaddr)=unpack_sockaddr_in($caller);
             my $clientip=inet_ntoa($iaddr);              my $clientip=inet_ntoa($iaddr);
             my $clientrec=($hostid{$clientip} ne undef);              my $clientrec=($hostid{$clientip} ne undef);
             &logthis("Connect from $clientip ($hostid{$clientip})");              &logthis(
   "<font color=yellow>INFO: Connect from $clientip ($hostid{$clientip})</font>");
             my $clientok;              my $clientok;
             if ($clientrec) {              if ($clientrec) {
       my $remotereq=<$client>;        my $remotereq=<$client>;
Line 275  sub make_new_child { Line 342  sub make_new_child {
       $clientok=1;        $clientok=1;
                       print $client "ok\n";                        print $client "ok\n";
                   } else {                    } else {
       &logthis("$clientip did not reply challenge");        &logthis(
    "<font color=blue>WARNING: $clientip did not reply challenge</font>");
                         print $client "bye\n";
                   }                    }
               } else {                } else {
   &logthis("$clientip failed to initialize: >$remotereq<");    &logthis(
                       "<font color=blue>WARNING: "
                      ."$clientip failed to initialize: >$remotereq< </font>");
     print $client "bye\n";
               }                }
     } else {      } else {
               &logthis("Unknown client $clientip");                &logthis(
    "<font color=blue>WARNING: Unknown client $clientip</font>");
                 print $client "bye\n";
             }              }
             if ($clientok) {              if ($clientok) {
 # ---------------- New known client connecting, could mean machine online again  # ---------------- New known client connecting, could mean machine online again
       &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");        &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
                 &logthis(
          "<font color=green>Established connection: $hostid{$clientip}</font>");
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
               while (my $userinput=<$client>) {                while (my $userinput=<$client>) {
                 chomp($userinput);                  chomp($userinput);
Line 342  sub make_new_child { Line 418  sub make_new_child {
      if ($wasenc==1) {       if ($wasenc==1) {
                        my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);                         my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
                        chomp($upass);                         chomp($upass);
                          $upass=unescape($upass);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $passfilename="$proname/passwd";                         my $passfilename="$proname/passwd";
                        if (-e $passfilename) {                         if (-e $passfilename) {
Line 450  sub make_new_child { Line 527  sub make_new_child {
                                  &logthis(                                   &logthis(
                                   "LWP GET: $message for $fname ($remoteurl)");                                    "LWP GET: $message for $fname ($remoteurl)");
                              } else {                               } else {
                            if ($remoteurl!~/\.meta$/) {
                                     my $mrequest=
                                      new HTTP::Request('GET',$remoteurl.'.meta');
                                     my $mresponse=
                                      $ua->request($mrequest,$fname.'.meta');
                                     if ($mresponse->is_error()) {
                       unlink($fname.'.meta');
                                     }
                            }
                                  rename($transname,$fname);                                   rename($transname,$fname);
      }       }
                           }                            }
Line 478  sub make_new_child { Line 564  sub make_new_child {
                        my $ownership=ishome($fname);                         my $ownership=ishome($fname);
                        if ($ownership eq 'owner') {                         if ($ownership eq 'owner') {
                         if (-e $fname) {                          if (-e $fname) {
    if (-d $fname) {
      print $client "directory\n";
                            } else {
                            $now=time;                             $now=time;
                            {                              { 
                             my $sh=IO::File->new(">$fname.$hostid{$clientip}");                              my $sh=IO::File->new(">$fname.$hostid{$clientip}");
Line 486  sub make_new_child { Line 575  sub make_new_child {
                            $fname=~s/\/home\/httpd\/html\/res/raw/;                             $fname=~s/\/home\/httpd\/html\/res/raw/;
                            $fname="http://$thisserver/".$fname;                             $fname="http://$thisserver/".$fname;
                            print $client "$fname\n";                             print $client "$fname\n";
            }
                         } else {                          } else {
          print $client "not_found\n";           print $client "not_found\n";
                         }                          }
        } else {         } else {
                         print $client "rejected\n";                          print $client "rejected\n";
        }         }
   # ------------------------------------------------------------------------- log
                      } elsif ($userinput =~ /^log/) {
                          my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
                          chomp($what);
                          my $proname=propath($udom,$uname);
                          my $now=time;
                          {
    my $hfh;
    if ($hfh=IO::File->new(">>$proname/activity.log")) { 
                               print $hfh "$now:$hostid{$clientip}:$what\n";
                               print $client "ok\n"; 
    } else {
                               print $client "error:$!\n";
           }
          }
 # ------------------------------------------------------------------------- put  # ------------------------------------------------------------------------- put
                    } elsif ($userinput =~ /^put/) {                     } elsif ($userinput =~ /^put/) {
                        my ($cmd,$udom,$uname,$namespace,$what)                        my ($cmd,$udom,$uname,$namespace,$what)
                           =split(/:/,$userinput);                            =split(/:/,$userinput);
                        $namespace=~s/\W//g;                        $namespace=~s/\//\_/g;
                         $namespace=~s/\W//g;
                         if ($namespace ne 'roles') {
                        chomp($what);                         chomp($what);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $now=time;                         my $now=time;
Line 507  sub make_new_child { Line 614  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 (dbmopen(%hash,"$proname/$namespace.db",0644)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
                              foreach $pair (@pairs) {
          ($key,$value)=split(/=/,$pair);
                                  $hash{$key}=$value;
                              }
      if (untie(%hash)) {
                                 print $client "ok\n";
                              } else {
                                 print $client "error:$!\n";
                              }
                          } else {
                              print $client "error:$!\n";
                          }
         } else {
                             print $client "refused\n";
                         }
   # -------------------------------------------------------------------- rolesput
                      } elsif ($userinput =~ /^rolesput/) {
       if ($wasenc==1) {
                          my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
                             =split(/:/,$userinput);
                          my $namespace='roles';
                          chomp($what);
                          my $proname=propath($udom,$uname);
                          my $now=time;
                          {
      my $hfh;
      if (
                                $hfh=IO::File->new(">>$proname/$namespace.hist")
          ) { 
                                     print $hfh "P:$now:$exedom:$exeuser:$what\n";
                                    }
          }
                          my @pairs=split(/\&/,$what);
         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
                            foreach $pair (@pairs) {                             foreach $pair (@pairs) {
        ($key,$value)=split(/=/,$pair);         ($key,$value)=split(/=/,$pair);
                                $hash{$key}=$value;                                 $hash{$key}=$value;
                            }                             }
    if (dbmclose(%hash)) {     if (untie(%hash)) {
                               print $client "ok\n";                                print $client "ok\n";
                            } else {                             } else {
                               print $client "error:$!\n";                                print $client "error:$!\n";
Line 520  sub make_new_child { Line 661  sub make_new_child {
                        } else {                         } else {
                            print $client "error:$!\n";                             print $client "error:$!\n";
                        }                         }
         } else {
                             print $client "refused\n";
                         }
 # ------------------------------------------------------------------------- get  # ------------------------------------------------------------------------- get
                    } elsif ($userinput =~ /^get/) {                     } elsif ($userinput =~ /^get/) {
                        my ($cmd,$udom,$uname,$namespace,$what)                         my ($cmd,$udom,$uname,$namespace,$what)
                           =split(/:/,$userinput);                            =split(/:/,$userinput);
                          $namespace=~s/\//\_/g;
                        $namespace=~s/\W//g;                         $namespace=~s/\W//g;
                        chomp($what);                         chomp($what);
                        my @queries=split(/\&/,$what);                         my @queries=split(/\&/,$what);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
                        if (dbmopen(%hash,"$proname/$namespace.db",0644)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            for ($i=0;$i<=$#queries;$i++) {                             for ($i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";                                 $qresult.="$hash{$queries[$i]}&";
                            }                             }
    if (dbmclose(%hash)) {     if (untie(%hash)) {
               $qresult=~s/\&$//;                $qresult=~s/\&$//;
                               print $client "$qresult\n";                                print $client "$qresult\n";
                            } else {                             } else {
Line 546  sub make_new_child { Line 691  sub make_new_child {
                    } elsif ($userinput =~ /^eget/) {                     } elsif ($userinput =~ /^eget/) {
                        my ($cmd,$udom,$uname,$namespace,$what)                         my ($cmd,$udom,$uname,$namespace,$what)
                           =split(/:/,$userinput);                            =split(/:/,$userinput);
                          $namespace=~s/\//\_/g;
                        $namespace=~s/\W//g;                         $namespace=~s/\W//g;
                        chomp($what);                         chomp($what);
                        my @queries=split(/\&/,$what);                         my @queries=split(/\&/,$what);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
                        if (dbmopen(%hash,"$proname/$namespace.db",0644)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            for ($i=0;$i<=$#queries;$i++) {                             for ($i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";                                 $qresult.="$hash{$queries[$i]}&";
                            }                             }
    if (dbmclose(%hash)) {     if (untie(%hash)) {
               $qresult=~s/\&$//;                $qresult=~s/\&$//;
                               if ($cipher) {                                if ($cipher) {
                                 my $cmdlength=length($qresult);                                  my $cmdlength=length($qresult);
Line 581  sub make_new_child { Line 727  sub make_new_child {
                    } elsif ($userinput =~ /^del/) {                     } elsif ($userinput =~ /^del/) {
                        my ($cmd,$udom,$uname,$namespace,$what)                         my ($cmd,$udom,$uname,$namespace,$what)
                           =split(/:/,$userinput);                            =split(/:/,$userinput);
                          $namespace=~s/\//\_/g;
                        $namespace=~s/\W//g;                         $namespace=~s/\W//g;
                        chomp($what);                         chomp($what);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
Line 592  sub make_new_child { Line 739  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 (dbmopen(%hash,"$proname/$namespace.db",0644)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
                            foreach $key (@keys) {                             foreach $key (@keys) {
                                delete($hash{$key});                                 delete($hash{$key});
                            }                             }
    if (dbmclose(%hash)) {     if (untie(%hash)) {
                               print $client "ok\n";                                print $client "ok\n";
                            } else {                             } else {
                               print $client "error:$!\n";                                print $client "error:$!\n";
Line 608  sub make_new_child { Line 755  sub make_new_child {
                    } elsif ($userinput =~ /^keys/) {                     } elsif ($userinput =~ /^keys/) {
                        my ($cmd,$udom,$uname,$namespace)                         my ($cmd,$udom,$uname,$namespace)
                           =split(/:/,$userinput);                            =split(/:/,$userinput);
                          $namespace=~s/\//\_/g;
                        $namespace=~s/\W//g;                         $namespace=~s/\W//g;
                        chomp($namespace);  
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
                        if (dbmopen(%hash,"$proname/$namespace.db",0644)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            foreach $key (keys %hash) {                             foreach $key (keys %hash) {
                                $qresult.="$key&";                                 $qresult.="$key&";
                            }                             }
    if (dbmclose(%hash)) {     if (untie(%hash)) {
               $qresult=~s/\&$//;                $qresult=~s/\&$//;
                               print $client "$qresult\n";                                print $client "$qresult\n";
                            } else {                             } else {
Line 629  sub make_new_child { Line 776  sub make_new_child {
                    } elsif ($userinput =~ /^dump/) {                     } elsif ($userinput =~ /^dump/) {
                        my ($cmd,$udom,$uname,$namespace)                         my ($cmd,$udom,$uname,$namespace)
                           =split(/:/,$userinput);                            =split(/:/,$userinput);
                          $namespace=~s/\//\_/g;
                        $namespace=~s/\W//g;                         $namespace=~s/\W//g;
                        chomp($namespace);  
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
                        if (dbmopen(%hash,"$proname/$namespace.db",0644)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            foreach $key (keys %hash) {                             foreach $key (keys %hash) {
                                $qresult.="$key=$hash{$key}&";                                 $qresult.="$key=$hash{$key}&";
                            }                             }
    if (dbmclose(%hash)) {     if (untie(%hash)) {
               $qresult=~s/\&$//;                $qresult=~s/\&$//;
                               print $client "$qresult\n";                                print $client "$qresult\n";
                            } else {                             } else {
Line 646  sub make_new_child { Line 793  sub make_new_child {
                        } else {                         } else {
                            print $client "error:$!\n";                             print $client "error:$!\n";
                        }                         }
   # ----------------------------------------------------------------------- store
                      } elsif ($userinput =~ /^store/) {
                         my ($cmd,$udom,$uname,$namespace,$rid,$what)
                             =split(/:/,$userinput);
                         $namespace=~s/\//\_/g;
                         $namespace=~s/\W//g;
                         if ($namespace ne 'roles') {
                          chomp($what);
                          my $proname=propath($udom,$uname);
                          my $now=time;
                          {
      my $hfh;
      if (
                                $hfh=IO::File->new(">>$proname/$namespace.hist")
          ) { print $hfh "P:$now:$rid:$what\n"; }
          }
                          my @pairs=split(/\&/,$what);
                            
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
                              my @previouskeys=split(/&/,$hash{"keys:$rid"});
                              my $key;
                              $hash{"version:$rid"}++;
                              my $version=$hash{"version:$rid"};
                              my $allkeys=''; 
                              foreach $pair (@pairs) {
          ($key,$value)=split(/=/,$pair);
                                  $allkeys.=$key.':';
                                  $hash{"$version:$rid:$key"}=$value;
                              }
                              $allkeys=~s/:$//;
                              $hash{"$version:keys:$rid"}=$allkeys;
      if (untie(%hash)) {
                                 print $client "ok\n";
                              } else {
                                 print $client "error:$!\n";
                              }
                          } else {
                              print $client "error:$!\n";
                          }
         } else {
                             print $client "refused\n";
                         }
   # --------------------------------------------------------------------- restore
                      } elsif ($userinput =~ /^restore/) {
                          my ($cmd,$udom,$uname,$namespace,$rid)
                             =split(/:/,$userinput);
                          $namespace=~s/\//\_/g;
                          $namespace=~s/\W//g;
                          chomp($rid);
                          my $proname=propath($udom,$uname);
                          my $qresult='';
         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                     my $version=$hash{"version:$rid"};
                              $qresult.="version=$version&";
                              my $scope;
                              for ($scope=1;$scope<=$version;$scope++) {
         my $vkeys=$hash{"$scope:keys:$rid"};
                                 my @keys=split(/:/,$vkeys);
                                 my $key;
                                 $qresult.="$scope:keys=$vkeys&";
                                 foreach $key (@keys) {
        $qresult.="$version:$key=".$hash{"$scope:$rid:$key"}."&";
                                 }                                  
                              }
      if (untie(%hash)) {
                 $qresult=~s/\&$//;
                                 print $client "$qresult\n";
                              } else {
                                 print $client "error:$!\n";
                              }
                          } else {
                              print $client "error:$!\n";
                          }
   # ------------------------------------------------------------------- querysend
                      } elsif ($userinput =~ /^querysend/) {
                          my ($cmd,$query)=split(/:/,$userinput);
          $query=~s/\n*$//g;
                        print $client sqlreply("$hostid{$clientip}\&$query")."\n";
   # ------------------------------------------------------------------ queryreply
                      } elsif ($userinput =~ /^queryreply/) {
                          my ($cmd,$id,$reply)=split(/:/,$userinput); 
          my $store;
                          my $execdir=$perlvar{'lonDaemons'};
                          if ($store=IO::File->new(">$execdir/tmp/$id")) {
      print $store $reply;
      close $store;
      print $client "ok\n";
          }
          else {
      print $client "error:$!\n";
          }
 # ----------------------------------------------------------------------- idput  # ----------------------------------------------------------------------- idput
                    } elsif ($userinput =~ /^idput/) {                     } elsif ($userinput =~ /^idput/) {
                        my ($cmd,$udom,$what)=split(/:/,$userinput);                         my ($cmd,$udom,$what)=split(/:/,$userinput);
Line 660  sub make_new_child { Line 898  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 (dbmopen(%hash,"$proname.db",0644)) {                   if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {
                            foreach $pair (@pairs) {                             foreach $pair (@pairs) {
        ($key,$value)=split(/=/,$pair);         ($key,$value)=split(/=/,$pair);
                                $hash{$key}=$value;                                 $hash{$key}=$value;
                            }                             }
    if (dbmclose(%hash)) {     if (untie(%hash)) {
                               print $client "ok\n";                                print $client "ok\n";
                            } else {                             } else {
                               print $client "error:$!\n";                                print $client "error:$!\n";
Line 681  sub make_new_child { Line 919  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 (dbmopen(%hash,"$proname.db",0644)) {                   if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
                            for ($i=0;$i<=$#queries;$i++) {                             for ($i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";                                 $qresult.="$hash{$queries[$i]}&";
                            }                             }
    if (dbmclose(%hash)) {     if (untie(%hash)) {
               $qresult=~s/\&$//;                $qresult=~s/\&$//;
                               print $client "$qresult\n";                                print $client "$qresult\n";
                            } else {                             } else {
Line 694  sub make_new_child { Line 932  sub make_new_child {
                        } else {                         } else {
                            print $client "error:$!\n";                             print $client "error:$!\n";
                        }                         }
   # ---------------------------------------------------------------------- tmpput
                      } elsif ($userinput =~ /^tmpput/) {
                          my ($cmd,$what)=split(/:/,$userinput);
          my $store;
                          $tmpsnum++;
                          my $id=$$.'_'.$clientip.'_'.$tmpsnum;
                          $id=~s/\W/\_/g;
                          $what=~s/\n//g;
                          my $execdir=$perlvar{'lonDaemons'};
                          if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
      print $store $what;
      close $store;
      print $client "$id\n";
          }
          else {
      print $client "error:$!\n";
          }
   
   # ---------------------------------------------------------------------- tmpget
                      } elsif ($userinput =~ /^tmpget/) {
                          my ($cmd,$id)=split(/:/,$userinput);
                          chomp($id);
                          $id=~s/\W/\_/g;
                          my $store;
                          my $execdir=$perlvar{'lonDaemons'};
                          if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
                              my $reply=<$store>;
      print $client "$reply\n";
                              close $store;
          }
          else {
      print $client "error:$!\n";
          }
   
   # -------------------------------------------------------------------------- ls
                      } elsif ($userinput =~ /^ls/) {
                          my ($cmd,$ulsdir)=split(/:/,$userinput);
                          my $ulsout='';
                          my $ulsfn;
                          if (-e $ulsdir) {
                             while ($ulsfn=<$ulsdir/*>) {
        my @ulsstats=stat($ulsfn);
                                $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
                             }
          } else {
                             $ulsout='no_such_dir';
                          }
                          if ($ulsout eq '') { $ulsout='empty'; }
                          print $client "$ulsout\n";
 # ------------------------------------------------------------- unknown command  # ------------------------------------------------------------- unknown command
                    } else {                     } else {
                        # unknown command                         # unknown command
Line 703  sub make_new_child { Line 990  sub make_new_child {
        }         }
             } else {              } else {
         print $client "refused\n";          print $client "refused\n";
                 &logthis("Rejected client $clientip, closing connection");                  &logthis("<font color=blue>WARNING: "
                   ."Rejected client $clientip, closing connection</font>");
             }                            }              
             &logthis("Disconnect from $clientip ($hostid{$clientip})");              &logthis("<font color=red>CRITICAL: "
                       ."Disconnect from $clientip ($hostid{$clientip})</font>");
 # =============================================================================  # =============================================================================
         }          }
           
Removed from v.1.3  
changed lines
  Added in v.1.20

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.