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

Diff for /loncom/lond between versions 1.263 and 1.274

version 1.263, 2004/10/21 16:05:50 version 1.274, 2005/01/03 16:34:46
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 localenroll;  use localenroll;
   use localstudentphoto;
 use File::Copy;  use File::Copy;
 use LONCAPA::ConfigFileEdit;  use LONCAPA::ConfigFileEdit;
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
Line 1311  sub user_authorization_type { Line 1312  sub user_authorization_type {
  my ($type,$otherinfo) = split(/:/,$result);   my ($type,$otherinfo) = split(/:/,$result);
  if($type =~ /^krb/) {   if($type =~ /^krb/) {
     $type = $result;      $type = $result;
  }   } else {
  &Reply( $replyfd, "$type:\n", $userinput);              $type .= ':';
           }
    &Reply( $replyfd, "$type\n", $userinput);
     }      }
       
     return 1;      return 1;
Line 1725  sub add_user_handler { Line 1728  sub add_user_handler {
  if (-e $passfilename) {   if (-e $passfilename) {
     &Failure( $client, "already_exists\n", $userinput);      &Failure( $client, "already_exists\n", $userinput);
  } else {   } else {
     my @fpparts=split(/\//,$passfilename);  
     my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];  
     my $fperror='';      my $fperror='';
     for (my $i=3;$i<= ($#fpparts-1);$i++) {      if (!&mkpath($passfilename)) {
  $fpnow.='/'.$fpparts[$i];    $fperror="error: ".($!+0)." mkdir failed while attempting "
  unless (-e $fpnow) {      ."makeuser";
     &logthis("mkdir $fpnow");  
     unless (mkdir($fpnow,0777)) {  
  $fperror="error: ".($!+0)." mkdir failed while attempting "  
     ."makeuser";  
     }  
  }  
     }      }
     unless ($fperror) {      unless ($fperror) {
  my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);   my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
Line 1967  sub fetch_user_file_handler { Line 1962  sub fetch_user_file_handler {
  # Note that any regular files in the way of this path are   # Note that any regular files in the way of this path are
  # wiped out to deal with some earlier folly of mine.   # wiped out to deal with some earlier folly of mine.
   
  my $path = $udir;   if (!&mkpath($udir.'/'.$ufile)) {
  if ($ufile =~m|(.+)/([^/]+)$|) {      &Failure($client, "unable_to_create\n", $userinput);    
     my @parts=split('/',$1);  
     foreach my $part (@parts) {  
  $path .= '/'.$part;  
  if( -f $path) {  
     unlink($path);  
  }  
  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 2090  sub mkdir_user_file_handler { Line 2074  sub mkdir_user_file_handler {
     } else {      } else {
  my $udir = &propath($udom,$uname);   my $udir = &propath($udom,$uname);
  if (-e $udir) {   if (-e $udir) {
     my $newdir=$udir.'/userfiles/'.$ufile;      my $newdir=$udir.'/userfiles/'.$ufile.'/';
     if (!-e $newdir) {      if (!&mkpath($newdir)) {
  my @parts=split('/',$newdir);   &Failure($client, "failed\n", "$cmd:$tail");
  my $path;  
  foreach my $part (@parts) {  
     $path .= '/'.$part;  
     if (!-e $path) {  
  mkdir($path,0770);  
     }  
  }  
  if (!-e $newdir) {  
     &Failure($client, "failed\n", "$cmd:$tail");  
  } else {  
     &Reply($client, "ok\n", "$cmd:$tail");  
  }  
     } else {  
  &Failure($client, "not_found\n", "$cmd:$tail");  
     }      }
       &Reply($client, "ok\n", "$cmd:$tail");
  } else {   } else {
     &Failure($client, "not_home\n", "$cmd:$tail");      &Failure($client, "not_home\n", "$cmd:$tail");
  }   }
Line 2866  sub store_handler { Line 2837  sub store_handler {
  chomp($what);   chomp($what);
  my @pairs=split(/\&/,$what);   my @pairs=split(/\&/,$what);
  my $hashref  = &tie_user_hash($udom, $uname, $namespace,   my $hashref  = &tie_user_hash($udom, $uname, $namespace,
        &GDBM_WRCREAT(), "P",         &GDBM_WRCREAT(), "S",
        "$rid:$what");         "$rid:$what");
  if ($hashref) {   if ($hashref) {
     my $now = time;      my $now = time;
Line 3137  sub reply_query_handler { Line 3108  sub reply_query_handler {
 #   $tail     - Tail of the command.  In this case consists of a colon  #   $tail     - Tail of the command.  In this case consists of a colon
 #               separated list contaning the domain to apply this to and  #               separated list contaning the domain to apply this to and
 #               an ampersand separated list of keyword=value pairs.  #               an ampersand separated list of keyword=value pairs.
   #               Each value is a colon separated list that includes:  
   #               description, institutional code and course owner.
   #               For backward compatibility with versions included
   #               in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional
   #               code and/or course owner are preserved from the existing 
   #               record when writing a new record in response to 1.1 or 
   #               1.2 implementations of lonnet::flushcourselogs().   
   #                      
 #   $client   - Socket open on the client.  #   $client   - Socket open on the client.
 # Returns:  # Returns:
 #   1    - indicating that processing should continue  #   1    - indicating that processing should continue
Line 3150  sub put_course_id_handler { Line 3129  sub put_course_id_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom, $what) = split(/:/, $tail);      my ($udom, $what) = split(/:/, $tail,2);
     chomp($what);      chomp($what);
     my $now=time;      my $now=time;
     my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
Line 3158  sub put_course_id_handler { Line 3137  sub put_course_id_handler {
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
     my ($key,$descr,$inst_code)=split(/=/,$pair);              my ($key,$courseinfo) = split(/=/,$pair,2);
     $hashref->{$key}=$descr.':'.$inst_code.':'.$now;              $courseinfo =~ s/=/:/g;
   
               my @current_items = split(/:/,$hashref->{$key});
               shift(@current_items); # remove description
               pop(@current_items);   # remove last access
               my $numcurrent = scalar(@current_items);
   
               my @new_items = split(/:/,$courseinfo);
               my $numnew = scalar(@new_items);
               if ($numcurrent > 0) {
                   if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier
                       $courseinfo .= ':'.join(':',@current_items);
                   } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X
                       $courseinfo .= ':'.$current_items[$numcurrent-1];
                   }
               }
       $hashref->{$key}=$courseinfo.':'.$now;
  }   }
  if (untie(%$hashref)) {   if (untie(%$hashref)) {
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
Line 3197  sub put_course_id_handler { Line 3192  sub put_course_id_handler {
 #                 description - regular expression that is used to filter  #                 description - regular expression that is used to filter
 #                            the dump.  Only keywords matching this regexp  #                            the dump.  Only keywords matching this regexp
 #                            will be used.  #                            will be used.
   #                 institutional code - optional supplied code to filter 
   #                            the dump. Only courses with an institutional code 
   #                            that match the supplied code will be returned.
   #                 owner    - optional supplied username of owner to filter
   #                            the dump.  Only courses for which the course 
   #                            owner matches the supplied username will be
   #                            returned. Implicit assumption that owner
   #                            is a user in the domain in which the
   #                            course database is defined.
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3207  sub dump_course_id_handler { Line 3211  sub dump_course_id_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$since,$description) =split(/:/,$tail);      my ($udom,$since,$description,$instcodefilter,$ownerfilter) =split(/:/,$tail);
     if (defined($description)) {      if (defined($description)) {
  $description=&unescape($description);   $description=&unescape($description);
     } else {      } else {
  $description='.';   $description='.';
     }      }
       if (defined($instcodefilter)) {
           $instcodefilter=&unescape($instcodefilter);
       } else {
           $instcodefilter='.';
       }
       if (defined($ownerfilter)) {
           $ownerfilter=&unescape($ownerfilter);
       } else {
           $ownerfilter='.';
       }
   
     unless (defined($since)) { $since=0; }      unless (defined($since)) { $since=0; }
     my $qresult='';      my $qresult='';
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
     my ($descr,$lasttime,$inst_code);      my ($descr,$lasttime,$inst_code,$owner);
     if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {              my @courseitems = split(/:/,$value);
  ($descr,$inst_code,$lasttime)=($1,$2,$3);              $lasttime = pop(@courseitems);
     } else {      ($descr,$inst_code,$owner)=@courseitems;
  ($descr,$lasttime) = split(/\:/,$value);  
     }  
     if ($lasttime<$since) { next; }      if ($lasttime<$since) { next; }
     if ($description eq '.') {              my $match = 1;
  $qresult.=$key.'='.$descr.':'.$inst_code.'&';      unless ($description eq '.') {
     } else {   my $unescapeDescr = &unescape($descr);
  my $unescapeVal = &unescape($descr);   unless (eval('$unescapeDescr=~/\Q$description\E/i')) {
  if (eval('$unescapeVal=~/\Q$description\E/i')) {                      $match = 0;
     $qresult.=$key.'='.$descr.':'.$inst_code.'&';  
  }   }
               }
               unless ($instcodefilter eq '.' || !defined($instcodefilter)) {
                   my $unescapeInstcode = &unescape($inst_code);
                   unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {
                       $match = 0;
                   }
     }      }
               unless ($ownerfilter eq '.' || !defined($ownerfilter)) {
                   my $unescapeOwner = &unescape($owner);
                   unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {
                       $match = 0;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
               }
  }   }
  if (untie(%$hashref)) {   if (untie(%$hashref)) {
     chop($qresult);      chop($qresult);
Line 3824  sub get_institutional_code_format_handle Line 3851  sub get_institutional_code_format_handle
           
     return 1;      return 1;
 }  }
   &register_handler("autoinstcodeformat",
     \&get_institutional_code_format_handler,0,1,0);
   
 &register_handler("autoinstcodeformat", \&get_institutional_code_format_handler,  
   0,1,0);  
   
 #  
 #  
 #  
 #  
 #  #
   # Gets a student's photo to exist (in the correct image type) in the user's 
   # directory.
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - A colon separated set of words that will be split into:
   #               $domain - student's domain
   #               $uname  - student username
   #               $type   - image type desired
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
   sub student_photo_handler {
       my ($cmd, $tail, $client) = @_;
       my ($domain,$uname,$type) = split(/:/, $tail);
   
       my $path=&propath($domain,$uname).
    '/userfiles/internal/studentphoto.'.$type;
       if (-e $path) {
    &Reply($client,"ok\n","$cmd:$tail");
    return 1;
       }
       &mkpath($path);
       my $file=&localstudentphoto::fetch($domain,$uname);
       if (!$file) {
    &Failure($client,"unavailable\n","$cmd:$tail");
    return 1;
       }
       if (!-e $path) { &convert_photo($file,$path); }
       if (-e $path) {
    &Reply($client,"ok\n","$cmd:$tail");
    return 1;
       }
       &Failure($client,"unable_to_convert\n","$cmd:$tail");
       return 1;
   }
   &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
   
   # mkpath makes all directories for a file, expects an absolute path with a
   # file or a trailing / if just a dir is passed
   # returns 1 on success 0 on failure
   sub mkpath {
       my ($file)=@_;
       my @parts=split(/\//,$file,-1);
       my $now=$parts[0].'/'.$parts[1].'/'.$parts[2];
       for (my $i=3;$i<= ($#parts-1);$i++) {
    $now.='/'.$parts[$i]; 
    if (!-e $now) {
       if  (!mkdir($now,0770)) { return 0; }
    }
       }
       return 1;
   }
   
 #---------------------------------------------------------------  #---------------------------------------------------------------
 #  #
 #   Getting, decoding and dispatching requests:  #   Getting, decoding and dispatching requests:
Line 4887  sub manage_permissions Line 4962  sub manage_permissions
 #  #
 sub password_path {  sub password_path {
     my ($domain, $user) = @_;      my ($domain, $user) = @_;
       return &propath($domain, $user).'/passwd';
   
     my $path   = &propath($domain, $user);  
     $path  .= "/passwd";  
   
     return $path;  
 }  }
   
 #   Password Filename  #   Password Filename
Line 5065  sub validate_user { Line 5135  sub validate_user {
  my $krbserver  = &Authen::Krb5::parse_name($krbservice);   my $krbserver  = &Authen::Krb5::parse_name($krbservice);
  my $credentials= &Authen::Krb5::cc_default();   my $credentials= &Authen::Krb5::cc_default();
  $credentials->initialize($krbclient);   $credentials->initialize($krbclient);
  my $krbreturn  = &Authen::KRb5::get_in_tkt_with_password($krbclient,   my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,
  $krbserver,   $krbserver,
  $password,   $password,
  $credentials);   $credentials);
Line 5403  sub make_passwd_file { Line 5473  sub make_passwd_file {
     return $result;      return $result;
 }  }
   
   sub convert_photo {
       my ($start,$dest)=@_;
       system("convert $start $dest");
   }
   
 sub sethost {  sub sethost {
     my ($remotereq) = @_;      my ($remotereq) = @_;
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
Removed from v.1.263  
changed lines
  Added in v.1.274

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