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

Diff for /loncom/lond between versions 1.77 and 1.96

version 1.77, 2002/04/27 13:10:47 version 1.96, 2002/09/13 02:46:12
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 $lasterror    = 10; # 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");
   
   #
   #  Convert an error return code from lcpasswd to a string value.
   #
   sub lcpasswdstrerror {
       my $ErrorCode = shift;
       if(($ErrorCode < 0) || ($ErrorCode > $lasterror)) {
    return "lcpasswd Unrecognized error return value ".$ErrorCode;
       } else {
    return $passwderrors($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 134  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 516  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 528  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 549  sub make_new_child { Line 580  sub make_new_child {
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
               while (my $userinput=<$client>) {                while (my $userinput=<$client>) {
                 chomp($userinput);                  chomp($userinput);
    Debug("Request = $userinput\n");
                 &status('Processing '.$hostid{$clientip}.': '.$userinput);                  &status('Processing '.$hostid{$clientip}.': '.$userinput);
                 my $wasenc=0;                  my $wasenc=0;
                 alarm(120);                  alarm(120);
Line 604  sub make_new_child { Line 636  sub make_new_child {
    } elsif ($userinput =~ /^currentauth/) {     } elsif ($userinput =~ /^currentauth/) {
      if ($wasenc==1) {       if ($wasenc==1) {
                        my ($cmd,$udom,$uname)=split(/:/,$userinput);                         my ($cmd,$udom,$uname)=split(/:/,$userinput);
                        my $proname=propath($udom,$uname);         my $result = GetAuthType($udom, $uname);
                        my $passfilename="$proname/passwd";         if($result eq "nouser") {
                        if (-e $passfilename) {     print $client "unknown_user\n";
    my $pf = IO::File->new($passfilename);         }
    my $realpasswd=<$pf>;         else {
    chomp($realpasswd);     print $client "$result\n"
    my ($howpwd,$contentpwd)=split(/:/,$realpasswd);         }
    my $availablecontent='';  
    if ($howpwd eq 'krb4') {  
        $availablecontent=$contentpwd;  
    }  
    print $client "$howpwd:$availablecontent\n";  
        } else {  
                           print $client "unknown_user\n";  
                        }  
      } else {       } else {
        print $client "refused\n";         print $client "refused\n";
      }       }
Line 661  sub make_new_child { Line 685  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 730  sub make_new_child { Line 771  sub make_new_child {
  close $pf;   close $pf;
  my $result = ($?>0 ? 'pwchange_failure'    my $result = ($?>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 746  sub make_new_child { Line 788  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 776  sub make_new_child { Line 818  sub make_new_child {
                                }                                 }
                            }                             }
                            unless ($fperror) {                             unless ($fperror) {
      if ($umode eq 'krb4') {         my $result=&make_passwd_file($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 836  sub make_new_child { Line 834  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($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 956  sub make_new_child { Line 913  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 1071  sub make_new_child { Line 1041  sub make_new_child {
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {        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);
          &ManagePermissions($key, $udom, $uname,
     &GetAuthType( $udom, 
    $uname));
                                $hash{$key}=$value;                                 $hash{$key}=$value;
          
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
                               print $client "ok\n";                                print $client "ok\n";
Line 1206  sub make_new_child { Line 1180  sub make_new_child {
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                              study($regexp);
                            foreach $key (keys %hash) {                             foreach $key (keys %hash) {
                                if (eval('$key=~/$regexp/')) {                                 my $unescapeKey = &unescape($key);
                                  if (eval('$unescapeKey=~/$regexp/')) {
                                   $qresult.="$key=$hash{$key}&";                                    $qresult.="$key=$hash{$key}&";
        }                                }
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
               $qresult=~s/\&$//;                $qresult=~s/\&$//;
Line 1294  sub make_new_child { Line 1270  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 1413  sub make_new_child { Line 1397  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 1466  sub make_new_child { Line 1456  sub make_new_child {
     }      }
 }  }
   
   
   #
   #   Checks to see if the input roleput request was to set
   # an author role.  If so, invokes the lchtmldir script to set
   # up a correct public_html 
   # Parameters:
   #    request   - The request sent to the rolesput subchunk.
   #                We're looking for  /domain/_au
   #    domain    - The domain in which the user is having roles doctored.
   #    user      - Name of the user for which the role is being put.
   #    authtype  - The authentication type associated with the user.
   #
   sub ManagePermissions
   {
       my $request = shift;
       my $domain  = shift;
       my $user    = shift;
       my $authtype= shift;
   
       # See if the request is of the form /$domain/_au
   
       if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
    my $execdir = $perlvar{'lonDaemons'};
    my $userhome= "/home/$user" ;
    Debug("system $execdir/lchtmldir $userhome $system $authtype");
    system("$execdir/lchtmldir $userhome $user $authtype");
       }
   }
   #
   #   GetAuthType - Determines the authorization type of a user in a domain.
   
   #     Returns the authorization type or nouser if there is no such user.
   #
   sub GetAuthType 
   {
       my $domain = shift;
       my $user   = shift;
   
       Debug("GetAuthType( $domain, $user ) \n");
       my $proname    = &propath($domain, $user); 
       my $passwdfile = "$proname/passwd";
       if( -e $passwdfile ) {
    my $pf = IO::File->new($passwdfile);
    my $realpassword = <$pf>;
    chomp($realpassword);
    Debug("Password info = $realpassword\n");
    my ($authtype, $contentpwd) = split(/:/, $realpassword);
    Debug("Authtype = $authtype, content = $contentpwd\n");
    my $availinfo = '';
    if($authtype eq 'krb4' or $authtype eq 'krb5') {
       $availinfo = $contentpwd;
    }
   
    return "$authtype:$availinfo";
       }
       else {
    Debug("Returning 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 subscribe {
       my ($userinput,$clientip)=@_;
       my $result;
       my ($cmd,$fname)=split(/:/,$userinput);
       my $ownership=&ishome($fname);
       if ($ownership eq 'owner') {
    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 ($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);
    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";
    }
       } 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)
   
 =head1 NAME  =head1 NAME
Line 1764  Crypt::IDEA Line 1972  Crypt::IDEA
 LWP::UserAgent()  LWP::UserAgent()
 GDBM_File  GDBM_File
 Authen::Krb4  Authen::Krb4
   Authen::Krb5
   
 =head1 COREQUISITES  =head1 COREQUISITES
   
Removed from v.1.77  
changed lines
  Added in v.1.96

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