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

Diff for /loncom/lond between versions 1.3 and 1.29

version 1.3, 1999/11/04 20:12:47 version 1.29, 2000/12/06 18:05:51
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
   # 12/05 Scott Harrison
   # 12/05 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 20  use LWP::UserAgent(); Line 27  use LWP::UserAgent();
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  use Authen::Krb4;
   
   # grabs exception and records it to log before exiting
   sub catchexception {
       my ($error)=@_;
       $SIG{'QUIT'}='DEFAULT';
       $SIG{__DIE__}='DEFAULT';
       &logthis("<font color=red>CRITICAL: "
        ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
        ."a crash with this error msg->[$error]</font>");
       if ($client) { print $client "error: $error\n"; }
       die($error);
   }
   
   # -------------------------------- Set signal handlers to record abnormal exits
   
   $SIG{'QUIT'}=\&catchexception;
   $SIG{__DIE__}=\&catchexception;
   
 # ------------------------------------ Read httpd access.conf and get variables  # ------------------------------------ Read httpd access.conf and get variables
   
 open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";  open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
Line 27  open (CONFIG,"/etc/httpd/conf/access.con Line 51  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 113  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 121  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 137  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 171  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 217  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 282  $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 331  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 346  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 361  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 437  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 445  sub make_new_child { Line 541  sub make_new_child {
                              $response=$ua->request($request,$transname);                               $response=$ua->request($request,$transname);
       }        }
                              if ($response->is_error()) {                               if ($response->is_error()) {
  unline($transname);   unlink($transname);
                                  my $message=$response->status_line;                                   my $message=$response->status_line;
                                  &logthis(                                   &logthis(
                                   "LWP GET: $message for $fname ($remoteurl)");                                    "LWP GET: $message for $fname ($remoteurl)");
                              } else {                               } else {
                            if ($remoteurl!~/\.meta$/) {
                                     my $ua=new LWP::UserAgent;
                                     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 584  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;
                             print $sh "$clientip:$now\n";                              if ($sh=
                                IO::File->new(">$fname.$hostid{$clientip}")) {
                                  print $sh "$clientip:$now\n";
       }
    }     }
                            $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 637  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 684  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 714  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 750  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 762  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 778  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 799  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 816  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.="$scope:$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 921  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 942  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 955  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 1013  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.29

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.