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

Diff for /loncom/lond between versions 1.165.2.1 and 1.189

version 1.165.2.1, 2004/01/14 01:20:40 version 1.189, 2004/05/07 17:51:58
Line 10 Line 10
 #  #
 # LON-CAPA is free software; you can redistribute it and/or modify  # LON-CAPA is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by  # it under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 2 of the License, or  # the Free Software Foundation; either version 2 of the License, or 
 # (at your option) any later version.  # (at your option) any later version.
 #  #
 # LON-CAPA is distributed in the hope that it will be useful,  # LON-CAPA is distributed in the hope that it will be useful,
Line 46  use Authen::Krb5; Line 46  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
 use File::Copy;  use File::Copy;
   use LONCAPA::ConfigFileEdit;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
Line 162  sub ReadManagerTable { Line 163  sub ReadManagerTable {
   
     #   Clean out the old table first..      #   Clean out the old table first..
   
     foreach my $key (keys %managers) {     foreach my $key (keys %managers) {
  delete $managers{$key};        delete $managers{$key};
     }     }
   
     my $tablename = $perlvar{'lonTabDir'}."/managers.tab";     my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
     if (!open (MANAGERS, $tablename)) {     if (!open (MANAGERS, $tablename)) {
  logthis('<font color="red">No manager table.  Nobody can manage!!</font>');        logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
  return;        return;
     }     }
     while(my $host = <MANAGERS>) {     while(my $host = <MANAGERS>) {
  chomp($host);        chomp($host);
  if (!defined $hostip{$host}) { # This is a non cluster member        if ($host =~ "^#") {                  # Comment line.
            logthis('<font color="green"> Skipping line: '. "$host</font>\n");
            next;
         }
         if (!defined $hostip{$host}) { # This is a non cluster member
     #  The entry is of the form:      #  The entry is of the form:
     #    cluname:hostname      #    cluname:hostname
     #  cluname - A 'cluster hostname' is needed in order to negotiate      #  cluname - A 'cluster hostname' is needed in order to negotiate
     #            the host key.      #            the host key.
     #  hostname- The dns name of the host.      #  hostname- The dns name of the host.
     #      #
                 my($cluname, $dnsname) = split(/:/, $host);
     my($cluname, $dnsname) = split(/:/, $host);            
     open(MGRPIPE, "/usr/bin/host $dnsname |") || die "Can't make host pipeline";            my $ip = gethostbyname($dnsname);
     my $dnsinfo = <MGRPIPE>;            if(defined($ip)) {                 # bad names don't deserve entry.
     chomp $dnsinfo;              my $hostip = inet_ntoa($ip);
     close MGRPIPE;              $managers{$hostip} = $cluname;
     my($jname, $jhas, $jaddress, $hostip) = split(/ /, $dnsinfo);              logthis('<font color="green"> registering manager '.
     $managers{$hostip} = $cluname;                      "$dnsname as $cluname with $hostip </font>\n");
  } else {           }
     $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber        } else {
  }           logthis('<font color="green"> existing host'." $host</font>\n");
     }           $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber
         }
      }
 }  }
   
 #  #
Line 279  sub AdjustHostContents { Line 285  sub AdjustHostContents {
     my $adjusted;      my $adjusted;
     my $me        = $perlvar{'lonHostID'};      my $me        = $perlvar{'lonHostID'};
   
     foreach my $line (split(/\n/,$contents)) {   foreach my $line (split(/\n/,$contents)) {
  if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {   if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
     chomp($line);      chomp($line);
     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);      my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
     if ($id eq $me) {      if ($id eq $me) {
  open(PIPE, " /usr/bin/host $name |") || die "Cant' make host pipeline";            my $ip = gethostbyname($name);
  my $hostinfo = <PIPE>;            my $ipnew = inet_ntoa($ip);
  close PIPE;           $ip = $ipnew;
   
  my ($hostname, $has, $address, $ipnew) = split(/ /,$hostinfo);  
  &logthis('<font color="green">'.  
  "hostname = $hostname me = $me, name = $name   actual ip = $ipnew </font>");  
   
  if ($hostname eq $name) { # Lookup succeeded..  
     &logthis('<font color="green"> look up ok <font>');  
     $ip = $ipnew;  
  } else {  
     &logthis('<font color="green"> Lookup failed: '  
      .$hostname." ne $name </font>");  
  }  
  #  Reconstruct the host line and append to adjusted:   #  Reconstruct the host line and append to adjusted:
   
  my $newline = "$id:$domain:$role:$name:$ip";     my $newline = "$id:$domain:$role:$name:$ip";
  if($maxcon ne "") { # Not all hosts have loncnew tuning params     if($maxcon ne "") { # Not all hosts have loncnew tuning params
     $newline .= ":$maxcon:$idleto:$mincon";       $newline .= ":$maxcon:$idleto:$mincon";
  }     }
  $adjusted .= $newline."\n";     $adjusted .= $newline."\n";
   
     } else { # Not me, pass unmodified.        } else { # Not me, pass unmodified.
  $adjusted .= $line."\n";     $adjusted .= $line."\n";
     }        }
  } else {                  # Blank or comment never re-written.   } else {                  # Blank or comment never re-written.
     $adjusted .= $line."\n"; # Pass blanks and comments as is.      $adjusted .= $line."\n"; # Pass blanks and comments as is.
  }   }
     }   }
     return $adjusted;   return $adjusted;
 }  }
 #  #
 #   InstallFile: Called to install an administrative file:  #   InstallFile: Called to install an administrative file:
Line 356  sub InstallFile { Line 350  sub InstallFile {
   
     return 1;      return 1;
 }  }
   #
   #   ConfigFileFromSelector: converts a configuration file selector
   #                 (one of host or domain at this point) into a 
   #                 configuration file pathname.
   #
   #  Parameters:
   #      selector  - Configuration file selector.
   #  Returns:
   #      Full path to the file or undef if the selector is invalid.
   #
   sub ConfigFileFromSelector {
       my $selector   = shift;
       my $tablefile;
   
       my $tabledir = $perlvar{'lonTabDir'}.'/';
       if ($selector eq "hosts") {
    $tablefile = $tabledir."hosts.tab";
       } elsif ($selector eq "domain") {
    $tablefile = $tabledir."domain.tab";
       } else {
    return undef;
       }
       return $tablefile;
   
   }
 #  #
 #   PushFile:  Called to do an administrative push of a file.  #   PushFile:  Called to do an administrative push of a file.
 #              - Ensure the file being pushed is one we support.  #              - Ensure the file being pushed is one we support.
Line 386  sub PushFile { Line 404  sub PushFile {
     # part of some elaborate spoof that managed somehow to authenticate.      # part of some elaborate spoof that managed somehow to authenticate.
     #      #
   
     my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir.  
     if ($filename eq "host") {      my $tablefile = ConfigFileFromSelector($filename);
  $tablefile .= "hosts.tab";      if(! (defined $tablefile)) {
     } elsif ($filename eq "domain") {  
  $tablefile .= "domain.tab";  
     } else {  
  return "refused";   return "refused";
     }      }
     #      #
Line 483  sub ReinitProcess { Line 498  sub ReinitProcess {
     }      }
     return 'ok';      return 'ok';
 }  }
   #   Validate a line in a configuration file edit script:
   #   Validation includes:
   #     - Ensuring the command is valid.
   #     - Ensuring the command has sufficient parameters
   #   Parameters:
   #     scriptline - A line to validate (\n has been stripped for what it's worth).
   #
   #   Return:
   #      0     - Invalid scriptline.
   #      1     - Valid scriptline
   #  NOTE:
   #     Only the command syntax is checked, not the executability of the
   #     command.
   #
   sub isValidEditCommand {
       my $scriptline = shift;
   
       #   Line elements are pipe separated:
   
       my ($command, $key, $newline)  = split(/\|/, $scriptline);
       &logthis('<font color="green"> isValideditCommand checking: '.
        "Command = '$command', Key = '$key', Newline = '$newline' </font>\n");
       
       if ($command eq "delete") {
    #
    #   key with no newline.
    #
    if( ($key eq "") || ($newline ne "")) {
       return 0; # Must have key but no newline.
    } else {
       return 1; # Valid syntax.
    }
       } elsif ($command eq "replace") {
    #
    #   key and newline:
    #
    if (($key eq "") || ($newline eq "")) {
       return 0;
    } else {
       return 1;
    }
       } elsif ($command eq "append") {
    if (($key ne "") && ($newline eq "")) {
       return 1;
    } else {
       return 0;
    }
       } else {
    return 0; # Invalid command.
       }
       return 0; # Should not get here!!!
   }
   #
   #   ApplyEdit - Applies an edit command to a line in a configuration 
   #               file.  It is the caller's responsiblity to validate the
   #               edit line.
   #   Parameters:
   #      $directive - A single edit directive to apply.  
   #                   Edit directives are of the form:
   #                  append|newline      - Appends a new line to the file.
   #                  replace|key|newline - Replaces the line with key value 'key'
   #                  delete|key          - Deletes the line with key value 'key'.
   #      $editor   - A config file editor object that contains the
   #                  file being edited.
   #
   sub ApplyEdit {
       my $directive   = shift;
       my $editor      = shift;
   
       # Break the directive down into its command and its parameters
       # (at most two at this point.  The meaning of the parameters, if in fact
       #  they exist depends on the command).
   
       my ($command, $p1, $p2) = split(/\|/, $directive);
   
       if($command eq "append") {
    $editor->Append($p1);          # p1 - key p2 null.
       } elsif ($command eq "replace") {
    $editor->ReplaceLine($p1, $p2);   # p1 - key p2 = newline.
       } elsif ($command eq "delete") {
    $editor->DeleteLine($p1);         # p1 - key p2 null.
       } else {          # Should not get here!!!
    die "Invalid command given to ApplyEdit $command"
       }
   }
   #
   # AdjustOurHost:
   #           Adjusts a host file stored in a configuration file editor object
   #           for the true IP address of this host. This is necessary for hosts
   #           that live behind a firewall.
   #           Those hosts have a publicly distributed IP of the firewall, but
   #           internally must use their actual IP.  We assume that a given
   #           host only has a single IP interface for now.
   # Formal Parameters:
   #     editor   - The configuration file editor to adjust.  This
   #                editor is assumed to contain a hosts.tab file.
   # Strategy:
   #    - Figure out our hostname.
   #    - Lookup the entry for this host.
   #    - Modify the line to contain our IP
   #    - Do a replace for this host.
   sub AdjustOurHost {
       my $editor        = shift;
   
       # figure out who I am.
   
       my $myHostName    = $perlvar{'lonHostID'}; # LonCAPA hostname.
   
       #  Get my host file entry.
   
       my $ConfigLine    = $editor->Find($myHostName);
       if(! (defined $ConfigLine)) {
    die "AdjustOurHost - no entry for me in hosts file $myHostName";
       }
       # figure out my IP:
       #   Use the config line to get my hostname.
       #   Use gethostbyname to translate that into an IP address.
       #
       my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
       my $BinaryIp = gethostbyname($name);
       my $ip       = inet_ntoa($ip);
       #
       #  Reassemble the config line from the elements in the list.
       #  Note that if the loncnew items were not present before, they will
       #  be now even if they would be empty
       #
       my $newConfigLine = $id;
       foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {
    $newConfigLine .= ":".$item;
       }
       #  Replace the line:
   
       $editor->ReplaceLine($id, $newConfigLine);
       
   }
   #
   #   ReplaceConfigFile:
   #              Replaces a configuration file with the contents of a
   #              configuration file editor object.
   #              This is done by:
   #              - Copying the target file to <filename>.old
   #              - Writing the new file to <filename>.tmp
   #              - Moving <filename.tmp>  -> <filename>
   #              This laborious process ensures that the system is never without
   #              a configuration file that's at least valid (even if the contents
   #              may be dated).
   #   Parameters:
   #        filename   - Name of the file to modify... this is a full path.
   #        editor     - Editor containing the file.
   #
   sub ReplaceConfigFile {
       my $filename  = shift;
       my $editor    = shift;
   
       CopyFile ($filename, $filename.".old");
   
       my $contents  = $editor->Get(); # Get the contents of the file.
   
       InstallFile($filename, $contents);
   }
   #   
   #
   #   Called to edit a configuration table  file
   #   Parameters:
   #      request           - The entire command/request sent by lonc or lonManage
   #   Return:
   #      The reply to send to the client.
   #
   sub EditFile {
       my $request = shift;
   
       #  Split the command into it's pieces:  edit:filetype:script
   
       my ($request, $filetype, $script) = split(/:/, $request,3); # : in script
   
       #  Check the pre-coditions for success:
   
       if($request != "edit") { # Something is amiss afoot alack.
    return "error:edit request detected, but request != 'edit'\n";
       }
       if( ($filetype ne "hosts")  &&
    ($filetype ne "domain")) {
    return "error:edit requested with invalid file specifier: $filetype \n";
       }
   
       #   Split the edit script and check it's validity.
   
       my @scriptlines = split(/\n/, $script);  # one line per element.
       my $linecount   = scalar(@scriptlines);
       for(my $i = 0; $i < $linecount; $i++) {
    chomp($scriptlines[$i]);
    if(!isValidEditCommand($scriptlines[$i])) {
       return "error:edit with bad script line: '$scriptlines[$i]' \n";
    }
       }
   
       #   Execute the edit operation.
       #   - Create a config file editor for the appropriate file and 
       #   - execute each command in the script:
       #
       my $configfile = ConfigFileFromSelector($filetype);
       if (!(defined $configfile)) {
    return "refused\n";
       }
       my $editor = ConfigFileEdit->new($configfile);
   
       for (my $i = 0; $i < $linecount; $i++) {
    ApplyEdit($scriptlines[$i], $editor);
       }
       # If the file is the host file, ensure that our host is
       # adjusted to have our ip:
       #
       if($filetype eq "host") {
    AdjustOurHost($editor);
       }
       #  Finally replace the current file with our file.
       #
       ReplaceConfigFile($configfile, $editor);
   
       return "ok\n";
   }
 #  #
 #  Convert an error return code from lcpasswd to a string value.  #  Convert an error return code from lcpasswd to a string value.
 #  #
Line 577  $server = IO::Socket::INET->new(LocalPor Line 812  $server = IO::Socket::INET->new(LocalPor
 # global variables  # global variables
   
 my %children               = ();       # keys are current child process IDs  my %children               = ();       # keys are current child process IDs
 my $children               = 0;        # current number of children  
   
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
     &status("Handling child death");      &status("Handling child death");
     my $pid = wait;      my $pid;
     if (defined($children{$pid})) {      do {
  &logthis("Child $pid died");   $pid = waitpid(-1,&WNOHANG());
  $children --;   if (defined($children{$pid})) {
  delete $children{$pid};      &logthis("Child $pid died");
     } else {      delete($children{$pid});
  &logthis("Unknown Child $pid died");   } elsif ($pid > 0) {
       &logthis("Unknown Child $pid died");
    }
       } while ( $pid > 0 );
       foreach my $child (keys(%children)) {
    $pid = waitpid($child,&WNOHANG());
    if ($pid > 0) {
       &logthis("Child $child - $pid looks like we missed it's death");
       delete($children{$pid});
    }
     }      }
     &status("Finished Handling child death");      &status("Finished Handling child death");
 }  }
Line 644  sub ReadHostTable { Line 887  sub ReadHostTable {
     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";      open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
           
     while (my $configline=<CONFIG>) {      while (my $configline=<CONFIG>) {
  my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);   if (!($configline =~ /^\s*\#/)) {
  chomp($ip); $ip=~s/\D+$//;      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
  $hostid{$ip}=$id;      chomp($ip); $ip=~s/\D+$//;
  $hostdom{$id}=$domain;      $hostid{$ip}=$id;
  $hostip{$id}=$ip;      $hostdom{$id}=$domain;
  if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }      $hostip{$id}=$ip;
       if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
    }
     }      }
     close(CONFIG);      close(CONFIG);
 }  }
Line 785  sub logstatus { Line 1030  sub logstatus {
     my $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
     {      {
     my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");      my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
     print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";      print $fh $$."\t".$clientname."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
     $fh->close();      $fh->close();
     }      }
     &status("Finished londstatus.txt");      &status("Finished londstatus.txt");
Line 1013  sub make_new_child { Line 1258  sub make_new_child {
     #  the pid hash.      #  the pid hash.
     #      #
     my $caller = getpeername($client);      my $caller = getpeername($client);
     my ($port,$iaddr)=unpack_sockaddr_in($caller);      my ($port,$iaddr);
     $clientip=inet_ntoa($iaddr);      if (defined($caller) && length($caller) > 0) {
    ($port,$iaddr)=unpack_sockaddr_in($caller);
       } else {
    &logthis("Unable to determine who caller was, getpeername returned nothing");
       }
       if (defined($iaddr)) {
    $clientip=inet_ntoa($iaddr);
       } else {
    &logthis("Unable to determine clinetip");
    $clientip='Unavailable';
       }
           
     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 die "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = $clientip;          $children{$pid} = $clientip;
         $children++;  
         &status('Started child '.$pid);          &status('Started child '.$pid);
         return;          return;
     } else {      } else {
Line 1224  sub make_new_child { Line 1478  sub make_new_child {
     }      }
 #--------------------------------------------------------------------- reinit  #--------------------------------------------------------------------- reinit
  } elsif($userinput =~ /^reinit/) { # Encoded and manager   } elsif($userinput =~ /^reinit/) { # Encoded and manager
     if (($wasenc == 1) && isManager) {   if (($wasenc == 1) && isManager) {
  my $cert = GetCertificate($userinput);   my $cert = GetCertificate($userinput);
  if(ValidManager($cert)) {   if(ValidManager($cert)) {
     chomp($userinput);   chomp($userinput);
     my $reply = ReinitProcess($userinput);   my $reply = ReinitProcess($userinput);
     print $client  "$reply\n";   print $client  "$reply\n";
    } else {
    print $client "refused\n";
    }
  } else {   } else {
     print $client "refused\n";   Reply($client, "refused\n", $userinput);
  }   }
     } else {  #------------------------------------------------------------------------- edit
  Reply($client, "refused\n", $userinput);      } elsif ($userinput =~ /^edit/) {    # encoded and manager:
    if(($wasenc ==1) && (isManager)) {
       my $cert = GetCertificate($userinput);
     }      if(ValidManager($cert)) {
                  my($command, $filetype, $script) = split(/:/, $userinput);
                  if (($filetype eq "hosts") || ($filetype eq "domain")) {
                     if($script ne "") {
         Reply($client, EditFile($userinput));
                     } else {
                        Reply($client,"refused\n",$userinput);
                     }
                  } else {
                     Reply($client,"refused\n",$userinput);
                  }
               } else {
                  Reply($client,"refused\n",$userinput);
               }
            } else {
        Reply($client,"refused\n",$userinput);
    }
 # ------------------------------------------------------------------------ auth  # ------------------------------------------------------------------------ auth
  } elsif ($userinput =~ /^auth/) { # Encoded and client only.      } elsif ($userinput =~ /^auth/) { # Encoded and client only.
     if (($wasenc==1) && isClient) {      if (($wasenc==1) && isClient) {
  my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);   my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
  chomp($upass);   chomp($upass);
Line 1555  sub make_new_child { Line 1828  sub make_new_child {
  } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.   } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
     if(isClient) {      if(isClient) {
  my ($cmd,$fname)=split(/:/,$userinput);   my ($cmd,$fname)=split(/:/,$userinput);
  my ($udom,$uname,$ufile)=split(/\//,$fname);   my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
  my $udir=propath($udom,$uname).'/userfiles';   my $udir=propath($udom,$uname).'/userfiles';
  unless (-e $udir) { mkdir($udir,0770); }   unless (-e $udir) { mkdir($udir,0770); }
  if (-e $udir) {   if (-e $udir) {
     $ufile=~s/^[\.\~]+//;                              $ufile=~s/^[\.\~]+//;
     $ufile=~s/\///g;                              my $path = $udir;
                               if ($ufile =~m|(.+)/([^/]+)$|) {
                                   my @parts=split('/',$1);
                                   foreach my $part (@parts) {
                                       $path .= '/'.$part;
                                       if ((-e $path)!=1) {
                                           mkdir($path,0770);
                                       }
                                   }
                               }
     my $destname=$udir.'/'.$ufile;      my $destname=$udir.'/'.$ufile;
     my $transname=$udir.'/'.$ufile.'.in.transit';      my $transname=$udir.'/'.$ufile.'.in.transit';
     my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;      my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
Line 1589  sub make_new_child { Line 1871  sub make_new_child {
  }   }
     } else {      } else {
  Reply($client, "refused\n", $userinput);   Reply($client, "refused\n", $userinput);
       }
   # --------------------------------------------------------- remove a user file 
    } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
       if(isClient) {
    my ($cmd,$fname)=split(/:/,$userinput);
    my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
    &logthis("$udom - $uname - $ufile");
    if ($ufile =~m|/\.\./|) {
       # any files paths with /../ in them refuse 
                               # to deal with
       print $client "refused\n";
    } else {
       my $udir=propath($udom,$uname);
       if (-e $udir) {
    my $file=$udir.'/userfiles/'.$ufile;
    if (-e $file) {
       unlink($file);
       if (-e $file) {
    print $client "failed\n";
       } else {
    print $client "ok\n";
       }
    } else {
       print $client "not_found\n";
    }
       } else {
    print $client "not_home\n";
       }
    }
       } else {
    Reply($client, "refused\n", $userinput);
     }      }
 # ------------------------------------------ authenticate access to a user file  # ------------------------------------------ authenticate access to a user file
  } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only   } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
Line 1600  sub make_new_child { Line 1912  sub make_new_child {
  if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.   if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
  $session.'.id')) {   $session.'.id')) {
     while (my $line=<ENVIN>) {      while (my $line=<ENVIN>) {
  if ($line=~/userfile\.$fname\=/) { $reply='ok'; }   if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
     }      }
     close(ENVIN);      close(ENVIN);
     print $client $reply."\n";      print $client $reply."\n";
Line 1616  sub make_new_child { Line 1928  sub make_new_child {
     if(isClient) {      if(isClient) {
  my ($cmd,$fname)=split(/:/,$userinput);   my ($cmd,$fname)=split(/:/,$userinput);
  if (-e $fname) {   if (-e $fname) {
     print $client &unsub($client,$fname,$clientip);      print $client &unsub($fname,$clientip);
  } else {   } else {
     print $client "not_found\n";      print $client "not_found\n";
  }   }
Line 1743  sub make_new_child { Line 2055  sub make_new_child {
  } else {   } else {
     print $client "error: ".($!+0)      print $client "error: ".($!+0)
  ." untie(GDBM) failed ".   ." untie(GDBM) failed ".
  "while attempting put\n";   "while attempting inc\n";
  }   }
     } else {      } else {
  print $client "error: ".($!)   print $client "error: ".($!)
     ." tie(GDBM) Failed ".      ." tie(GDBM) Failed ".
     "while attempting put\n";      "while attempting inc\n";
     }      }
  } else {   } else {
     print $client "refused\n";      print $client "refused\n";
Line 1959  sub make_new_child { Line 2271  sub make_new_child {
  my %hash;   my %hash;
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {   if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
     foreach my $key (@keys) {      foreach my $key (@keys) {
  delete($hash{&unescape($key)});   delete($hash{$key});
     }      }
     if (untie(%hash)) {      if (untie(%hash)) {
  print $client "ok\n";   print $client "ok\n";
Line 2074  sub make_new_child { Line 2386  sub make_new_child {
  my $proname=propath($udom,$uname);   my $proname=propath($udom,$uname);
  my %hash;   my %hash;
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {   if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
        study($regexp);  
        while (my ($key,$value) = each(%hash)) {         while (my ($key,$value) = each(%hash)) {
    if ($regexp eq '.') {     if ($regexp eq '.') {
        $qresult.=$key.'='.$value.'&';         $qresult.=$key.'='.$value.'&';
Line 2312  sub make_new_child { Line 2623  sub make_new_child {
     $qresult.=$key.'='.$descr.'&';      $qresult.=$key.'='.$descr.'&';
  } else {   } else {
     my $unescapeVal = &unescape($descr);      my $unescapeVal = &unescape($descr);
     if (eval('$unescapeVal=~/$description/i')) {      if (eval('$unescapeVal=~/\Q$description\E/i')) {
  $qresult.="$key=$descr&";   $qresult.="$key=$descr&";
     }      }
  }   }
Line 2470  sub make_new_child { Line 2781  sub make_new_child {
 # -------------------------------------------------------------------------- ls  # -------------------------------------------------------------------------- ls
  } elsif ($userinput =~ /^ls/) {   } elsif ($userinput =~ /^ls/) {
     if(isClient) {      if(isClient) {
    my $obs;
    my $rights;
  my ($cmd,$ulsdir)=split(/:/,$userinput);   my ($cmd,$ulsdir)=split(/:/,$userinput);
  my $ulsout='';   my $ulsout='';
  my $ulsfn;   my $ulsfn;
Line 2477  sub make_new_child { Line 2790  sub make_new_child {
     if(-d $ulsdir) {      if(-d $ulsdir) {
  if (opendir(LSDIR,$ulsdir)) {   if (opendir(LSDIR,$ulsdir)) {
     while ($ulsfn=readdir(LSDIR)) {      while ($ulsfn=readdir(LSDIR)) {
    undef $obs, $rights; 
  my @ulsstats=stat($ulsdir.'/'.$ulsfn);   my @ulsstats=stat($ulsdir.'/'.$ulsfn);
  $ulsout.=$ulsfn.'&'.   #We do some obsolete checking here
     join('&',@ulsstats).':';   if(-e $ulsdir.'/'.$ulsfn.".meta") { 
       open(FILE, $ulsdir.'/'.$ulsfn.".meta");
       my @obsolete=<FILE>;
       foreach my $obsolete (@obsolete) {
           if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } 
    if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
       }
    }
    $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
    if($obs eq '1') { $ulsout.="&1"; }
    else { $ulsout.="&0"; }
    if($rights eq '1') { $ulsout.="&1:"; }
    else { $ulsout.="&0:"; }
     }      }
     closedir(LSDIR);      closedir(LSDIR);
  }   }
Line 2590  sub ManagePermissions Line 2916  sub ManagePermissions
     my $authtype= shift;      my $authtype= shift;
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     &logthis("ruequest is $request");  
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};   my $execdir = $perlvar{'lonDaemons'};
  my $userhome= "/home/$user" ;   my $userhome= "/home/$user" ;
Line 2715  sub chatadd { Line 3040  sub chatadd {
 sub unsub {  sub unsub {
     my ($fname,$clientip)=@_;      my ($fname,$clientip)=@_;
     my $result;      my $result;
       my $unsubs = 0; # Number of successful unsubscribes:
   
   
       # An old way subscriptions were handled was to have a 
       # subscription marker file:
   
       Debug("Attempting unlink of $fname.$clientname");
     if (unlink("$fname.$clientname")) {      if (unlink("$fname.$clientname")) {
  $result="ok\n";   $unsubs++; # Successful unsub via marker file.
     } else {      } 
  $result="not_subscribed\n";  
     }      # The more modern way to do it is to have a subscription list
       # file:
   
     if (-e "$fname.subscription") {      if (-e "$fname.subscription") {
  my $found=&addline($fname,$clientname,$clientip,'');   my $found=&addline($fname,$clientname,$clientip,'');
  if ($found) { $result="ok\n"; }   if ($found) { 
       $unsubs++;
    }
       } 
   
       #  If either or both of these mechanisms succeeded in unsubscribing a 
       #  resource we can return ok:
   
       if($unsubs) {
    $result = "ok\n";
     } else {      } else {
  if ($result != "ok\n") { $result="not_subscribed\n"; }   $result = "not_subscribed\n";
     }      }
   
     return $result;      return $result;
 }  }
   
Line 2847  sub make_passwd_file { Line 3191  sub make_passwd_file {
  }   }
     } elsif ($umode eq 'unix') {      } elsif ($umode eq 'unix') {
  {   {
       #
       #  Don't allow the creation of privileged accounts!!! that would
       #  be real bad!!!
       #
       my $uid = getpwnam($uname);
       if((defined $uid) && ($uid == 0)) {
    &logthis(">>>Attempted to create privilged account blocked");
    return "no_priv_account_error\n";
       }
   
     my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";      my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
     {      {
  &Debug("Executing external: ".$execpath);   &Debug("Executing external: ".$execpath);
Removed from v.1.165.2.1  
changed lines
  Added in v.1.189

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