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

Diff for /loncom/lond between versions 1.79 and 1.101

version 1.79, 2002/05/08 02:31:04 version 1.101, 2002/10/03 15:02:22
Line 53 Line 53
 # 02/12 Gerd Kortemeyer  # 02/12 Gerd Kortemeyer
 # 02/19 Matthew Hall  # 02/19 Matthew Hall
 # 02/25 Gerd Kortemeyer  # 02/25 Gerd Kortemeyer
   # 05/11 Scott Harrison
 ###  ###
   
 # based on "Perl Cookbook" ISBN 1-56592-243-3  # based on "Perl Cookbook" ISBN 1-56592-243-3
Line 61 Line 62
 # HUPs  # HUPs
 # uses IDEA encryption  # uses IDEA encryption
   
   use lib '/home/httpd/lib/perl/';
   use LONCAPA::Configuration;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
 use Apache::File;  use Apache::File;
Line 70  use Crypt::IDEA; Line 74  use Crypt::IDEA;
 use LWP::UserAgent();  use LWP::UserAgent();
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  use Authen::Krb4;
   use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
   
Line 78  my $DEBUG = 0;         # Non zero to ena Line 83  my $DEBUG = 0;         # Non zero to ena
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
   
   #
   #  The array below are password error strings."
   #
   my $lastpwderror    = 13; # Largest error number from lcpasswd.
   my @passwderrors = ("ok",
      "lcpasswd must be run as user 'www'",
      "lcpasswd got incorrect number of arguments",
      "lcpasswd did not get the right nubmer of input text lines",
      "lcpasswd too many simultaneous pwd changes in progress",
      "lcpasswd User does not exist.",
      "lcpasswd Incorrect current passwd",
      "lcpasswd Unable to su to root.",
      "lcpasswd Cannot set new passwd.",
      "lcpasswd Username has invalid characters",
      "lcpasswd Invalid characters in password",
       "11", "12",
       "lcpasswd Password mismatch");
   
   
   #  The array below are lcuseradd error strings.:
   
   my $lastadderror = 13;
   my @adderrors    = ("ok",
       "User ID mismatch, lcuseradd must run as user www",
       "lcuseradd Incorrect number of command line parameters must be 3",
       "lcuseradd Incorrect number of stdinput lines, must be 3",
       "lcuseradd Too many other simultaneous pwd changes in progress",
       "lcuseradd User does not exist",
       "lcuseradd Unabel to mak ewww member of users's group",
       "lcuseradd Unable to su to root",
       "lcuseradd Unable to set password",
       "lcuseradd Usrname has invbalid charcters",
       "lcuseradd Password has an invalid character",
       "lcuseradd User already exists",
       "lcuseradd Could not add user.",
       "lcuseradd Password mismatch");
   
   
   #
   #  Convert an error return code from lcpasswd to a string value.
   #
   sub lcpasswdstrerror {
       my $ErrorCode = shift;
       if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
    return "lcpasswd Unrecognized error return value ".$ErrorCode;
       } else {
    return $passwderrors[$ErrorCode];
       }
   }
   
   #
   # Convert an error return code from lcuseradd to a string value:
   #
   sub lcuseraddstrerror {
       my $ErrorCode = shift;
       if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
    return "lcuseradd - Unrecognized error code: ".$ErrorCode;
       } else {
    return $adderrors[$ErrorCode];
       }
   }
   
 # grabs exception and records it to log before exiting  # grabs exception and records it to log before exiting
 sub catchexception {  sub catchexception {
     my ($error)=@_;      my ($error)=@_;
Line 101  sub timeout { Line 168  sub timeout {
 $SIG{'QUIT'}=\&catchexception;  $SIG{'QUIT'}=\&catchexception;
 $SIG{__DIE__}=\&catchexception;  $SIG{__DIE__}=\&catchexception;
   
 # ------------------------------------ Read httpd access.conf and get variables  # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
   &status("Read loncapa.conf and loncapa_apache.conf");
 open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";  my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
   my %perlvar=%{$perlvarref};
 while ($configline=<CONFIG>) {  undef $perlvarref;
     if ($configline =~ /PerlSetVar/) {  
  my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);  
         chomp($varvalue);  
         $perlvar{$varname}=$varvalue;  
     }  
 }  
 close(CONFIG);  
   
 # ----------------------------- Make sure this process is running from user=www  # ----------------------------- Make sure this process is running from user=www
 my $wwwid=getpwnam('www');  my $wwwid=getpwnam('www');
Line 490  sub make_new_child { Line 550  sub make_new_child {
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
   
         $tmpsnum=0;          $tmpsnum=0;
       #---------------------------------------------------- kerberos 5 initialization
           &Authen::Krb5::init_context();
           &Authen::Krb5::init_ets();
   
         # 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++) {
             &status('Idle, waiting for connection');              &status('Idle, waiting for connection');
Line 499  sub make_new_child { Line 562  sub make_new_child {
 # =============================================================================  # =============================================================================
             # do something with the connection              # do something with the connection
 # -----------------------------------------------------------------------------  # -----------------------------------------------------------------------------
       $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
                                         # connection liveness.
             # see if we know client and check for spoof IP by challenge              # see if we know client and check for spoof IP by challenge
             my $caller=getpeername($client);              my $caller=getpeername($client);
             my ($port,$iaddr)=unpack_sockaddr_in($caller);              my ($port,$iaddr)=unpack_sockaddr_in($caller);
Line 630  sub make_new_child { Line 695  sub make_new_child {
                           my ($howpwd,$contentpwd)=split(/:/,$realpasswd);                            my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
                           my $pwdcorrect=0;                            my $pwdcorrect=0;
                           if ($howpwd eq 'internal') {                            if ($howpwd eq 'internal') {
         &Debug("Internal auth");
       $pwdcorrect=        $pwdcorrect=
   (crypt($upass,$contentpwd) eq $contentpwd);    (crypt($upass,$contentpwd) eq $contentpwd);
                           } elsif ($howpwd eq 'unix') {                            } elsif ($howpwd eq 'unix') {
                               $contentpwd=(getpwnam($uname))[1];        &Debug("Unix auth");
       my $pwauth_path="/usr/local/sbin/pwauth";                                if((getpwnam($uname))[1] eq "") { #no such user!
       unless ($contentpwd eq 'x') {    $pwdcorrect = 0;
   $pwdcorrect=        } else {
                                     (crypt($upass,$contentpwd) eq $contentpwd);    $contentpwd=(getpwnam($uname))[1];
       }    my $pwauth_path="/usr/local/sbin/pwauth";
     unless ($contentpwd eq 'x') {
         $pwdcorrect=
     (crypt($upass,$contentpwd) eq 
      $contentpwd);
     }
     
       elsif (-e $pwauth_path) {        elsif (-e $pwauth_path) {
   open PWAUTH, "|$pwauth_path" or    open PWAUTH, "|$pwauth_path" or
       die "Cannot invoke authentication";        die "Cannot invoke authentication";
Line 646  sub make_new_child { Line 718  sub make_new_child {
   close PWAUTH;    close PWAUTH;
   $pwdcorrect=!$?;    $pwdcorrect=!$?;
       }        }
         }
                           } elsif ($howpwd eq 'krb4') {                            } elsif ($howpwd eq 'krb4') {
                              $null=pack("C",0);                               $null=pack("C",0);
      unless ($upass=~/$null/) {       unless ($upass=~/$null/) {
Line 654  sub make_new_child { Line 727  sub make_new_child {
                                         $contentpwd,'krbtgt',$contentpwd,1,                                          $contentpwd,'krbtgt',$contentpwd,1,
      $upass) == 0);       $upass) == 0);
      } else { $pwdcorrect=0; }       } else { $pwdcorrect=0; }
                             } elsif ($howpwd eq 'krb5') {
         $null=pack("C",0);
         unless ($upass=~/$null/) {
     my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
     my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
     my $krbserver=&Authen::Krb5::parse_name($krbservice);
     my $credentials=&Authen::Krb5::cc_default();
     $credentials->initialize($krbclient);
     my $krbreturn = 
       &Authen::Krb5::get_in_tkt_with_password(
        $krbclient,$krbserver,$upass,$credentials);
   #  unless ($krbreturn) {
   #      &logthis("Krb5 Error: ".
   #       &Authen::Krb5::error());
   #  }
     $pwdcorrect = ($krbreturn == 1);
      } else { $pwdcorrect=0; }
                           } elsif ($howpwd eq 'localauth') {                            } elsif ($howpwd eq 'localauth') {
     $pwdcorrect=&localauth::localauth($uname,$upass,      $pwdcorrect=&localauth::localauth($uname,$upass,
       $contentpwd);        $contentpwd);
Line 677  sub make_new_child { Line 767  sub make_new_child {
                        chomp($npass);                         chomp($npass);
                        $upass=&unescape($upass);                         $upass=&unescape($upass);
                        $npass=&unescape($npass);                         $npass=&unescape($npass);
        &logthis("Trying to change password for $uname");         &Debug("Trying to change password for $uname");
        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 687  sub make_new_child { Line 777  sub make_new_child {
                           chomp($realpasswd);                            chomp($realpasswd);
                           my ($howpwd,$contentpwd)=split(/:/,$realpasswd);                            my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
                           if ($howpwd eq 'internal') {                            if ($howpwd eq 'internal') {
      &Debug("internal auth");
    if (crypt($upass,$contentpwd) eq $contentpwd) {     if (crypt($upass,$contentpwd) eq $contentpwd) {
      my $salt=time;       my $salt=time;
                              $salt=substr($salt,6,2);                               $salt=substr($salt,6,2);
Line 703  sub make_new_child { Line 794  sub make_new_child {
       # one way or another.        # one way or another.
       # First: Make sure the current password is        # First: Make sure the current password is
       #        correct        #        correct
         &Debug("auth is unix");
       $contentpwd=(getpwnam($uname))[1];        $contentpwd=(getpwnam($uname))[1];
       my $pwdcorrect = "0";        my $pwdcorrect = "0";
       my $pwauth_path="/usr/local/sbin/pwauth";        my $pwauth_path="/usr/local/sbin/pwauth";
Line 714  sub make_new_child { Line 806  sub make_new_child {
       die "Cannot invoke authentication";        die "Cannot invoke authentication";
   print PWAUTH "$uname\n$upass\n";    print PWAUTH "$uname\n$upass\n";
   close PWAUTH;    close PWAUTH;
   $pwdcorrect=!$?;    &Debug("exited pwauth with $? ($uname,$upass) ");
     $pwdcorrect=($? == 0);
       }        }
      if ($pwdcorrect) {       if ($pwdcorrect) {
  my $execdir=$perlvar{'lonDaemons'};   my $execdir=$perlvar{'lonDaemons'};
  my $pf = IO::File->new("|$execdir/lcpasswd");   &Debug("Opening lcpasswd pipeline");
    my $pf = IO::File->new("|$execdir/lcpasswd > /home/www/lcpasswd.log");
  print $pf "$uname\n$npass\n$npass\n";   print $pf "$uname\n$npass\n$npass\n";
  close $pf;   close $pf;
  my $result = ($?>0 ? 'pwchange_failure'    my $err = $?;
    my $result = ($err>0 ? 'pwchange_failure' 
        : 'ok');         : 'ok');
  &logthis("Result of password change for $uname: $result");   &logthis("Result of password change for $uname: ".
     &lcpasswdstrerror($?));
  print $client "$result\n";   print $client "$result\n";
      } else {       } else {
  print $client "non_authorized\n";   print $client "non_authorized\n";
Line 739  sub make_new_child { Line 835  sub make_new_child {
      }       }
 # -------------------------------------------------------------------- makeuser  # -------------------------------------------------------------------- makeuser
                    } elsif ($userinput =~ /^makeuser/) {                     } elsif ($userinput =~ /^makeuser/) {
      Debug("Make user received");       &Debug("Make user received");
                 my $oldumask=umask(0077);                  my $oldumask=umask(0077);
      if ($wasenc==1) {       if ($wasenc==1) {
                        my                          my 
Line 769  sub make_new_child { Line 865  sub make_new_child {
                                }                                 }
                            }                             }
                            unless ($fperror) {                             unless ($fperror) {
      if ($umode eq 'krb4') {         my $result=&make_passwd_file($uname, $umode,$npass,
                                {       $passfilename);
                                  my $pf = IO::File->new(">$passfilename");         print $client $result;
             print $pf "krb4:$npass\n";   
                                }               
                                print $client "ok\n";  
                              } elsif ($umode eq 'internal') {  
        my $salt=time;  
                                $salt=substr($salt,6,2);  
        my $ncpass=crypt($npass,$salt);  
                                {   
  &Debug("Creating internal auth");  
  my $pf = IO::File->new(">$passfilename");  
             print $pf "internal:$ncpass\n";   
                                }  
                                print $client "ok\n";  
      } elsif ($umode eq 'localauth') {  
        {  
  my $pf = IO::File->new(">$passfilename");  
             print $pf "localauth:$npass\n";  
        }  
        print $client "ok\n";  
      } elsif ($umode eq 'unix') {  
        {  
  my $execpath="$perlvar{'lonDaemons'}/".  
               "lcuseradd";  
  {  
      &Debug("Executing external: ".  
   $execpath);  
      my $se = IO::File->new("|$execpath");  
      print $se "$uname\n";  
      print $se "$npass\n";  
      print $se "$npass\n";  
  }  
                                  my $pf = IO::File->new(">$passfilename");  
             print $pf "unix:\n";   
        }  
        print $client "ok\n";  
      } elsif ($umode eq 'none') {  
                                {   
                                  my $pf = IO::File->new(">$passfilename");  
             print $pf "none:\n";   
                                }               
                                print $client "ok\n";  
                              } else {  
                                print $client "auth_mode_error\n";  
                              }    
                            } else {                             } else {
                                print $client "$fperror\n";                                 print $client "$fperror\n";
                            }                             }
Line 829  sub make_new_child { Line 881  sub make_new_child {
        &Debug("Changing authorization");         &Debug("Changing authorization");
       if ($wasenc==1) {        if ($wasenc==1) {
                        my                          my 
                        ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);         ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
                        chomp($npass);                         chomp($npass);
        &Debug("cmd = ".$cmd." domain= ".$udom.         &Debug("cmd = ".$cmd." domain= ".$udom.
       "uname =".$uname." umode= ".$umode);        "uname =".$uname." umode= ".$umode);
                        $npass=&unescape($npass);                         $npass=&unescape($npass);
                        my $proname=propath($udom,$uname);                         my $proname=&propath($udom,$uname);
                        my $passfilename="$proname/passwd";                         my $passfilename="$proname/passwd";
        if ($udom ne $perlvar{'lonDefDomain'}) {         if ($udom ne $perlvar{'lonDefDomain'}) {
                            print $client "not_right_domain\n";                             print $client "not_right_domain\n";
                        } else {                         } else {
    if ($umode eq 'krb4') {     my $result=&make_passwd_file($uname, $umode,$npass,
                                {    $passfilename);
    my $pf = IO::File->new(">$passfilename");     print $client $result;
    print $pf "krb4:$npass\n";   
                                }               
                                print $client "ok\n";  
    } elsif ($umode eq 'internal') {  
        my $salt=time;  
                                $salt=substr($salt,6,2);  
        my $ncpass=crypt($npass,$salt);  
                                {   
    my $pf = IO::File->new(">$passfilename");  
    print $pf "internal:$ncpass\n";   
                                }  
                                print $client "ok\n";  
    } elsif ($umode eq 'localauth') {  
        {  
    my $pf = IO::File->new(">$passfilename");  
    print $pf "localauth:$npass\n";  
        }  
        print $client "ok\n";  
    } elsif ($umode eq 'unix') {  
        {  
    my $execpath="$perlvar{'lonDaemons'}/".  
        "lcuseradd";  
    {  
        my $se = IO::File->new("|$execpath");  
        print $se "$uname\n";  
        print $se "$npass\n";  
        print $se "$npass\n";  
    }  
    my $pf = IO::File->new(">$passfilename");  
    print $pf "unix:\n";   
        }  
        print $client "ok\n";  
    } elsif ($umode eq 'none') {  
                                {   
    my $pf = IO::File->new(">$passfilename");  
    print $pf "none:\n";   
                                }               
                                print $client "ok\n";  
    } else {  
                                print $client "auth_mode_error\n";  
    }    
                        }                         }
      } else {       } else {
        print $client "refused\n";         print $client "refused\n";
Line 949  sub make_new_child { Line 960  sub make_new_child {
        } else {         } else {
  print $client "rejected\n";   print $client "rejected\n";
                        }                         }
   # -------------------------------------- fetch a user file from a remote server
                      } elsif ($userinput =~ /^fetchuserfile/) {
                         my ($cmd,$fname)=split(/:/,$userinput);
         my ($udom,$uname,$ufile)=split(/\//,$fname);
                         my $udir=propath($udom,$uname).'/userfiles';
                         unless (-e $udir) { mkdir($udir,0770); }
                          if (-e $udir) {
                          $ufile=~s/^[\.\~]+//;
                          $ufile=~s/\///g;
                          my $transname=$udir.'/'.$ufile;
                          my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
                                my $response;
                                 {
                                my $ua=new LWP::UserAgent;
                                my $request=new HTTP::Request('GET',"$remoteurl");
                                $response=$ua->request($request,$transname);
         }
                                if ($response->is_error()) {
    unlink($transname);
                                    my $message=$response->status_line;
                                    &logthis(
                                     "LWP GET: $message for $fname ($remoteurl)");
    print $client "failed\n";
                                } else {
                                    print $client "ok\n";
                                }
                        } else {
                          print $client "not_home\n";
                        } 
   # ------------------------------------------ authenticate access to a user file
                      } elsif ($userinput =~ /^tokenauthuserfile/) {
                          my ($cmd,$fname,$session)=split(/:/,$userinput);
                          chomp($session);
                          $reply='non_auth';
                          if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
                                         $session.'.id')) {
                           while ($line=<ENVIN>) {
      if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
                           }
                           close(ENVIN);
                           print $client $reply."\n";
          } else {
    print $client "invalid_token\n";
                          }
 # ----------------------------------------------------------------- unsubscribe  # ----------------------------------------------------------------- unsubscribe
                    } elsif ($userinput =~ /^unsub/) {                     } elsif ($userinput =~ /^unsub/) {
                        my ($cmd,$fname)=split(/:/,$userinput);                         my ($cmd,$fname)=split(/:/,$userinput);
                        if (-e $fname) {                         if (-e $fname) {
                            if (unlink("$fname.$hostid{$clientip}")) {     print $client &unsub($client,$fname,$clientip);
                               print $client "ok\n";  
    } else {  
                               print $client "not_subscribed\n";  
    }  
                        } else {                         } else {
    print $client "not_found\n";     print $client "not_found\n";
                        }                         }
 # ------------------------------------------------------------------- subscribe  # ------------------------------------------------------------------- subscribe
                    } elsif ($userinput =~ /^sub/) {                     } elsif ($userinput =~ /^sub/) {
                        my ($cmd,$fname)=split(/:/,$userinput);         print $client &subscribe($userinput,$clientip);
                        my $ownership=ishome($fname);  
                        if ($ownership eq 'owner') {  
                         if (-e $fname) {  
  if (-d $fname) {  
    print $client "directory\n";  
                          } else {  
                            $now=time;  
                            {   
     my $sh;  
                             if ($sh=  
                              IO::File->new(">$fname.$hostid{$clientip}")) {  
                                print $sh "$clientip:$now\n";  
     }  
    }  
                            unless ($fname=~/\.meta$/) {  
        unlink("$fname.meta.$hostid{$clientip}");  
                            }  
                            $fname=~s/\/home\/httpd\/html\/res/raw/;  
                            $fname="http://$thisserver/".$fname;  
                            print $client "$fname\n";  
          }  
                         } else {  
          print $client "not_found\n";  
                         }  
        } else {  
                         print $client "rejected\n";  
        }  
 # ------------------------------------------------------------------------- log  # ------------------------------------------------------------------------- log
                    } elsif ($userinput =~ /^log/) {                     } elsif ($userinput =~ /^log/) {
                        my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);                         my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
Line 1200  sub make_new_child { Line 1224  sub make_new_child {
        } else {         } else {
                           $regexp='.';                            $regexp='.';
        }         }
                        my $proname=propath($udom,$uname);  
                        my $qresult='';                         my $qresult='';
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {                         my $proname=propath($udom,$uname);
                            foreach $key (keys %hash) {      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
                                if (eval('$key=~/$regexp/')) {                             study($regexp);
                                   $qresult.="$key=$hash{$key}&";                             while (($key,$value) = each(%hash)) {
        }                                 if ($regexp eq '.') {
                                      $qresult.=$key.'='.$value.'&';
                                  } else {
                                      my $unescapeKey = &unescape($key);
                                      if (eval('$unescapeKey=~/$regexp/')) {
                                          $qresult.="$key=$value&";
                                      }
                                  }
                            }                             }
    if (untie(%hash)) {                             if (untie(%hash)) {
               $qresult=~s/\&$//;                                 chop($qresult);
                               print $client "$qresult\n";                                 print $client "$qresult\n";
                            } else {                             } else {
                               print $client "error:$!\n";                                 print $client "error:$!\n";
                            }                             }
                        } else {                         } else {
                            print $client "error:$!\n";                             print $client "error:$!\n";
Line 1291  sub make_new_child { Line 1321  sub make_new_child {
                        } else {                         } else {
                            print $client "error:$!\n";                             print $client "error:$!\n";
                        }                         }
   # -------------------------------------------------------------------- chatsend
                      } elsif ($userinput =~ /^chatsend/) {
                          my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
                          &chatadd($cdom,$cnum,$newpost);
                          print $client "ok\n";
   # -------------------------------------------------------------------- chatretr
                      } elsif ($userinput =~ /^chatretr/) {
                          my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);
                          my $reply='';
                          foreach (&getchat($cdom,$cnum)) {
      $reply.=&escape($_).':';
                          }
                          $reply=~s/\:$//;
                          print $client $reply."\n";
 # ------------------------------------------------------------------- querysend  # ------------------------------------------------------------------- querysend
                    } elsif ($userinput =~ /^querysend/) {                     } elsif ($userinput =~ /^querysend/) {
                        my ($cmd,$query,                         my ($cmd,$query,
    $custom,$customshow)=split(/:/,$userinput);     $arg1,$arg2,$arg3)=split(/\:/,$userinput);
        $query=~s/\n*$//g;         $query=~s/\n*$//g;
        unless ($custom or $customshow) {         print $client "".
    print $client "".  
        sqlreply("$hostid{$clientip}\&$query")."\n";  
        }  
        else {  
    print $client "".  
        sqlreply("$hostid{$clientip}\&$query".         sqlreply("$hostid{$clientip}\&$query".
  "\&$custom"."\&$customshow")."\n";   "\&$arg1"."\&$arg2"."\&$arg3")."\n";
        }  
 # ------------------------------------------------------------------ queryreply  # ------------------------------------------------------------------ queryreply
                    } elsif ($userinput =~ /^queryreply/) {                     } elsif ($userinput =~ /^queryreply/) {
                        my ($cmd,$id,$reply)=split(/:/,$userinput);                          my ($cmd,$id,$reply)=split(/:/,$userinput); 
Line 1410  sub make_new_child { Line 1448  sub make_new_child {
                        my $ulsout='';                         my $ulsout='';
                        my $ulsfn;                         my $ulsfn;
                        if (-e $ulsdir) {                         if (-e $ulsdir) {
  if (opendir(LSDIR,$ulsdir)) {                             if(-d $ulsdir) {
                           while ($ulsfn=readdir(LSDIR)) {                                 if (opendir(LSDIR,$ulsdir)) {
      my @ulsstats=stat($ulsdir.'/'.$ulsfn);                                     while ($ulsfn=readdir(LSDIR)) {
                              $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';                                         my @ulsstats=stat($ulsdir.'/'.$ulsfn);
                           }                                         $ulsout.=$ulsfn.'&'.
                           closedir(LSDIR);                                                  join('&',@ulsstats).':';
         }                                     }
        } else {                                     closedir(LSDIR);
                                  }
                              } else {
                                  my @ulsstats=stat($ulsdir);
                                  $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
                              }
                          } else {
                           $ulsout='no_such_dir';                            $ulsout='no_such_dir';
                        }                         }
                        if ($ulsout eq '') { $ulsout='empty'; }                         if ($ulsout eq '') { $ulsout='empty'; }
Line 1512  sub GetAuthType Line 1556  sub GetAuthType
  my ($authtype, $contentpwd) = split(/:/, $realpassword);   my ($authtype, $contentpwd) = split(/:/, $realpassword);
  Debug("Authtype = $authtype, content = $contentpwd\n");   Debug("Authtype = $authtype, content = $contentpwd\n");
  my $availinfo = '';   my $availinfo = '';
  if($authtype eq 'krb4') {   if($authtype eq 'krb4' or $authtype eq 'krb5') {
     $availinfo = $contentpwd;      $availinfo = $contentpwd;
  }   }
   
Line 1522  sub GetAuthType Line 1566  sub GetAuthType
  Debug("Returning nouser");   Debug("Returning nouser");
  return "nouser";   return "nouser";
     }      }
       }
   
   sub addline {
       my ($fname,$hostid,$ip,$newline)=@_;
       my $contents;
       my $found=0;
       my $expr='^'.$hostid.':'.$ip.':';
       $expr =~ s/\./\\\./g;
       if ($sh=IO::File->new("$fname.subscription")) {
    while (my $subline=<$sh>) {
       if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
    }
    $sh->close();
       }
       $sh=IO::File->new(">$fname.subscription");
       if ($contents) { print $sh $contents; }
       if ($newline) { print $sh $newline; }
       $sh->close();
       return $found;
   }
   
   sub getchat {
       my ($cdom,$cname)=@_;
       my %hash;
       my $proname=&propath($cdom,$cname);
       my @entries=();
       if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
       &GDBM_READER(),0640)) {
    @entries=map { $_.':'.$hash{$_} } sort keys %hash;
    untie %hash;
       }
       return @entries;
   }
   
   sub chatadd {
       my ($cdom,$cname,$newchat)=@_;
       my %hash;
       my $proname=&propath($cdom,$cname);
       my @entries=();
       if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
       &GDBM_WRCREAT(),0640)) {
    @entries=map { $_.':'.$hash{$_} } sort keys %hash;
    my $time=time;
    my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
    my ($thentime,$idnum)=split(/\_/,$lastid);
    my $newid=$time.'_000000';
    if ($thentime==$time) {
       $idnum=~s/^0+//;
       $idnum++;
       $idnum=substr('000000'.$idnum,-6,6);
       $newid=$time.'_'.$idnum;
    }
    $hash{$newid}=$newchat;
    my $expired=$time-3600;
    foreach (keys %hash) {
       my ($thistime)=($_=~/(\d+)\_/);
       if ($thistime<$expired) {
    delete $hash{$_};
       }
    }
    untie %hash;
       }
   }
   
   sub unsub {
       my ($fname,$clientip)=@_;
       my $result;
       if (unlink("$fname.$hostid{$clientip}")) {
    $result="ok\n";
       } else {
    $result="not_subscribed\n";
       }
       if (-e "$fname.subscription") {
    my $found=&addline($fname,$hostid{$clientip},$clientip,'');
    if ($found) { $result="ok\n"; }
       } else {
    if ($result != "ok\n") { $result="not_subscribed\n"; }
       }
       return $result;
   }
   
   sub currentversion {
       my $fname=shift;
       my $version=-1;
       my $ulsdir='';
       if ($fname=~/^(.+)\/[^\/]+$/) {
          $ulsdir=$1;
       }
       $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
       $fname=~s/\.(\w+)$/\.\(\\d\+\)\.$1\$/;
       if (-e $fname) { $version=1; }
       if (-e $ulsdir) {
          if(-d $ulsdir) {
             if (opendir(LSDIR,$ulsdir)) {
                while ($ulsfn=readdir(LSDIR)) {
   # see if this is a regular file (ignore links produced earlier)
                    my $thisfile=$ulsdir.'/'.$ulsfn;
                    unless (-l $thisfile) {
       if ($thisfile=~/$fname/) {
           if ($1>$version) { $version=$1; }
                       }
    }
                }
                closedir(LSDIR);
                $version++;
             }
         }
      }
      return $version;
   }
   
   sub thisversion {
       my $fname=shift;
       my $version=-1;
       if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
    $version=$1;
       }
       return $version;
   }
   
   sub subscribe {
       my ($userinput,$clientip)=@_;
       my $result;
       my ($cmd,$fname)=split(/:/,$userinput);
       my $ownership=&ishome($fname);
       if ($ownership eq 'owner') {
   # explitly asking for the current version?
           unless (-e $fname) {
               my $currentversion=&currentversion($fname);
       if (&thisversion($fname)==$currentversion) {
                   if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
       my $root=$1;
                       my $extension=$2;
                       symlink($root.'.'.$extension,
                               $root.'.'.$currentversion.'.'.$extension);
                   }
               }
           }
    if (-e $fname) {
       if (-d $fname) {
    $result="directory\n";
       } else {
    if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
    $now=time;
    my $found=&addline($fname,$hostid{$clientip},$clientip,
      "$hostid{$clientip}:$clientip:$now\n");
    if ($found) { $result="$fname\n"; }
    # if they were subscribed to only meta data, delete that
                   # subscription, when you subscribe to a file you also get
                   # the metadata
    unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
    $fname=~s/\/home\/httpd\/html\/res/raw/;
    $fname="http://$thisserver/".$fname;
    $result="$fname\n";
       }
    } else {
       $result="not_found\n";
    }
       } else {
    $result="rejected\n";
       }
       return $result;
   }
   
   sub make_passwd_file {
       my ($uname, $umode,$npass,$passfilename)=@_;
       my $result="ok\n";
       if ($umode eq 'krb4' or $umode eq 'krb5') {
    {
       my $pf = IO::File->new(">$passfilename");
       print $pf "$umode:$npass\n";
    }
       } elsif ($umode eq 'internal') {
    my $salt=time;
    $salt=substr($salt,6,2);
    my $ncpass=crypt($npass,$salt);
    {
       &Debug("Creating internal auth");
       my $pf = IO::File->new(">$passfilename");
       print $pf "internal:$ncpass\n"; 
    }
       } elsif ($umode eq 'localauth') {
    {
       my $pf = IO::File->new(">$passfilename");
       print $pf "localauth:$npass\n";
    }
       } elsif ($umode eq 'unix') {
    {
       my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
       {
    &Debug("Executing external: ".$execpath);
    &Debug("user  = ".$uname.", Password =". $npass);
    my $se = IO::File->new("|$execpath > /home/www/lcuseradd.log");
    print $se "$uname\n";
    print $se "$npass\n";
    print $se "$npass\n";
       }
       my $useraddok = $?;
       if($useraddok > 0) {
    &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
       }
       my $pf = IO::File->new(">$passfilename");
       print $pf "unix:\n";
    }
       } elsif ($umode eq 'none') {
    {
       my $pf = IO::File->new(">$passfilename");
       print $pf "none:\n";
    }
       } else {
    $result="auth_mode_error\n";
       }
       return $result;
 }  }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
Line 1823  Crypt::IDEA Line 2079  Crypt::IDEA
 LWP::UserAgent()  LWP::UserAgent()
 GDBM_File  GDBM_File
 Authen::Krb4  Authen::Krb4
   Authen::Krb5
   
 =head1 COREQUISITES  =head1 COREQUISITES
   
Removed from v.1.79  
changed lines
  Added in v.1.101

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