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

Diff for /loncom/lond between versions 1.13 and 1.23

version 1.13, 2000/06/29 20:43:03 version 1.23, 2000/12/05 16:51:41
Line 7 Line 7
 # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,  # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
 # 03/07,05/31 Gerd Kortemeyer  # 03/07,05/31 Gerd Kortemeyer
 # 06/26 Scott Harrison  # 06/26 Scott Harrison
 # 06/29 Gerd Kortemeyer  # 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
Line 25  use LWP::UserAgent(); Line 25  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 ($signal)=@_;
       &logthis("<font color=red>CRITICAL: "
        ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
        ."$signal with this parameter->[$@]</font>");
       die($@);
   }
   
   # grabs exception and records it to log before exiting
   # NOTE: we must NOT use the regular (non-overrided) die function in
   # the code because a handler CANNOT be attached to it
   # (despite what some of the documentation says about SIG{__DIE__}.
   sub catchdie {
       my ($message)=@_;
       &logthis("<font color=red>CRITICAL: "
        ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
        ."\_\_DIE\_\_ with this parameter->[$message]</font>");
       die($message);
   }
   
   # -------------------------------- 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")
       || catchdie "Can't read access.conf";
   
 while ($configline=<CONFIG>) {  while ($configline=<CONFIG>) {
     if ($configline =~ /PerlSetVar/) {      if ($configline =~ /PerlSetVar/) {
Line 38  while ($configline=<CONFIG>) { Line 65  while ($configline=<CONFIG>) {
 }  }
 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) { catchdie "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
   
 open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";  open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab")
       || catchdie "Can't read host file";
   
 while ($configline=<CONFIG>) {  while ($configline=<CONFIG>) {
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
Line 59  $server = IO::Socket::INET->new(LocalPor Line 98  $server = IO::Socket::INET->new(LocalPor
                                 Proto     => 'tcp',                                  Proto     => 'tcp',
                                 Reuse     => 1,                                  Reuse     => 1,
                                 Listen    => 10 )                                  Listen    => 10 )
   or die "making socket: $@\n";    or catchdie "making socket: $@\n";
   
 # --------------------------------------------------------- Do global variables  # --------------------------------------------------------- Do global variables
   
Line 217  sub propath { Line 256  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;
Line 242  sub ishome { Line 281  sub ishome {
   
 $fpid=fork;  $fpid=fork;
 exit if $fpid;  exit if $fpid;
 die "Couldn't fork: $!" unless defined ($fpid);  catchdie "Couldn't fork: $!" unless defined ($fpid);
   
 POSIX::setsid() or die "Can't start new session: $!";  POSIX::setsid() or catchdie "Can't start new session: $!";
   
 # ------------------------------------------------------- Write our PID on disk  # ------------------------------------------------------- Write our PID on disk
   
Line 283  sub make_new_child { Line 322  sub make_new_child {
     # block signal for fork      # block signal for fork
     $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 catchdie "Can't block SIGINT for fork: $!\n";
           
     die "fork: $!" unless defined ($pid = fork);      catchdie "fork: $!" unless defined ($pid = fork);
           
     if ($pid) {      if ($pid) {
         # Parent records the child's birth and returns.          # Parent records the child's birth and returns.
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or catchdie "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = 1;          $children{$pid} = 1;
         $children++;          $children++;
         return;          return;
Line 300  sub make_new_child { Line 339  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 catchdie "Can't unblock SIGINT for fork: $!\n";
   
         $tmpsnum=0;          $tmpsnum=0;
           
Line 333  sub make_new_child { Line 372  sub make_new_child {
                   } else {                    } else {
       &logthis(        &logthis(
  "<font color=blue>WARNING: $clientip did not reply challenge</font>");   "<font color=blue>WARNING: $clientip did not reply challenge</font>");
                         print $client "bye\n";
                   }                    }
               } else {                } else {
   &logthis(    &logthis(
                     "<font color=blue>WARNING: "                      "<font color=blue>WARNING: "
                    ."$clientip failed to initialize: >$remotereq< </font>");                     ."$clientip failed to initialize: >$remotereq< </font>");
     print $client "bye\n";
               }                }
     } else {      } else {
               &logthis(                &logthis(
  "<font color=blue>WARNING: Unknown client $clientip</font>");   "<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
Line 513  sub make_new_child { Line 555  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 541  sub make_new_child { Line 592  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 549  sub make_new_child { Line 603  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";
                         }                          }
Line 647  sub make_new_child { Line 702  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_WRCREAT,0640)) {        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]}&";
                            }                             }
Line 670  sub make_new_child { Line 725  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_WRCREAT,0640)) {        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]}&";
                            }                             }
Line 732  sub make_new_child { Line 787  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_WRCREAT,0640)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            foreach $key (keys %hash) {                             foreach $key (keys %hash) {
                                $qresult.="$key&";                                 $qresult.="$key&";
                            }                             }
Line 753  sub make_new_child { Line 808  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_WRCREAT,0640)) {        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}&";
                            }                             }
Line 817  sub make_new_child { Line 872  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_WRCREAT,0640)) {        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 827  sub make_new_child { Line 882  sub make_new_child {
                               my $key;                                my $key;
                               $qresult.="$scope:keys=$vkeys&";                                $qresult.="$scope:keys=$vkeys&";
                               foreach $key (@keys) {                                foreach $key (@keys) {
      $qresult.="$version:$key=".$hash{"$scope:$rid:$key"}."&";       $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
                               }                                                                  }                                  
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
Line 892  sub make_new_child { Line 947  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_WRCREAT,0640)) {                   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]}&";
                            }                             }
Line 952  sub make_new_child { Line 1007  sub make_new_child {
        } else {         } else {
                           $ulsout='no_such_dir';                            $ulsout='no_such_dir';
                        }                         }
                          if ($ulsout eq '') { $ulsout='empty'; }
                        print $client "$ulsout\n";                         print $client "$ulsout\n";
 # ------------------------------------------------------------- unknown command  # ------------------------------------------------------------- unknown command
                    } else {                     } else {
Removed from v.1.13  
changed lines
  Added in v.1.23

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