[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.452 and 1.458

version 1.452, 2003/12/04 20:09:35 version 1.458, 2003/12/09 16:22:06
Line 506  sub changepass { Line 506  sub changepass {
   
 sub queryauthenticate {  sub queryauthenticate {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     if (($perlvar{'lonRole'} eq 'library') &&       my $uhome=&homeserver($uname,$udom);
         ($udom eq $perlvar{'lonDefDomain'})) {      if (!$uhome) {
  my $answer=reply("encrypt:currentauth:$udom:$uname",   &logthis("User $uname at $udom is unknown when looking for authentication mechanism");
  $perlvar{'lonHostID'});   return 'no_host';
  unless ($answer eq 'unknown_user' or $answer eq 'refused') {      }
     if (length($answer)) {      my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
  return $answer;      if ($answer =~ /^(unknown_user|refused|con_lost)/) {
     }   &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
     else {  
  &logthis("User $uname at $udom lacks an authentication mechanism");  
  return 'no_host';  
     }  
  }  
     }  
   
     my $tryserver;  
     foreach $tryserver (keys %libserv) {  
  if ($hostdom{$tryserver} eq $udom) {  
            my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);  
    unless ($answer eq 'unknown_user' or $answer eq 'refused') {  
        if (length($answer)) {  
    return $answer;  
        }  
        else {  
    &logthis("User $uname at $udom lacks an authentication mechanism");  
    return 'no_host';  
        }  
    }  
        }  
     }      }
     &logthis("User $uname at $udom lacks an authentication mechanism");          return $answer;
     return 'no_host';  
 }  }
   
 # --------- Try to authenticate user from domain's lib servers (first this one)  # --------- Try to authenticate user from domain's lib servers (first this one)
Line 1341  sub flushcourselogs { Line 1319  sub flushcourselogs {
 # Writes to the dynamic metadata of resources to get hit counts, etc.  # Writes to the dynamic metadata of resources to get hit counts, etc.
 #  #
     foreach my $entry (keys(%accesshash)) {      foreach my $entry (keys(%accesshash)) {
         my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);          if ($entry =~ /___count$/) {
         if ($type eq 'count'){              my ($dom,$name);
               ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
               if (! defined($dom) || $dom eq '' || 
                   ! defined($name) || $name eq '') {
                   my $cid = $ENV{'request.course.id'};
                   $dom  = $ENV{'request.'.$cid.'.domain'};
                   $name = $ENV{'request.'.$cid.'.num'};
               }
             my $value = $accesshash{$entry};              my $value = $accesshash{$entry};
             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);              my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
             my %temphash=($url => $value);              my %temphash=($url => $value);
Line 1357  sub flushcourselogs { Line 1342  sub flushcourselogs {
                 }                  }
             }              }
         } else {          } else {
               my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
             my %temphash=($entry => $accesshash{$entry});              my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
Line 1397  sub courselog { Line 1383  sub courselog {
     } else {      } else {
  $courselogs{$ENV{'request.course.id'}}.=$what;   $courselogs{$ENV{'request.course.id'}}.=$what;
     }      }
 #    if (length($courselogs{$ENV{'request.course.id'}})>4048) {      if (length($courselogs{$ENV{'request.course.id'}})>4048) {
     if (length($courselogs{$ENV{'request.course.id'}})>48) {  
  &flushcourselogs();   &flushcourselogs();
     }      }
 }  }
Line 1420  sub courseacclog { Line 1405  sub courseacclog {
   
 sub countacc {  sub countacc {
     my $url=&declutter(shift);      my $url=&declutter(shift);
       return if (! defined($url) || $url eq '');
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($ENV{'request.course.id'}) { return ''; }
     $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;      $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';      my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
Line 3144  sub modifyuser { Line 3130  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;
     my $cid='';      if (!$cid) {
     unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$ENV{'request.course.id'}) {
  return 'not_in_class';      return 'not_in_class';
    }
     }      }
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
Line 3157  sub modifystudent { Line 3144  sub modifystudent {
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
                                         $last,$gene,$usec,$end,$start);   $gene,$usec,$end,$start,$type,$cid);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
     # Get the course id from the environment   $cid) = @_;
     my $cid='';      my ($cdom,$cnum,$chome);
     unless ($cid=$ENV{'request.course.id'}) {      if (!$cid) {
  return 'not_in_class';   unless ($cid=$ENV{'request.course.id'}) {
       return 'not_in_class';
    }
    $cdom=$ENV{'course.'.$cid.'.domain'};
    $cnum=$ENV{'course.'.$cid.'.num'};
       } else {
    ($cdom,$cnum)=split(/_/,$cid);
       }
       $chome=$ENV{'course.'.$cid.'.home'};
       if (!$chome) {
    $chome=&homeserver($cnum,$cdom);
     }      }
       if (!$chome) { return 'unknown_course'; }
     # Make sure the user exists      # Make sure the user exists
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such user';   return 'error: no such user';
     }      }
     #  
     # Get student data if we were not given enough information      # Get student data if we were not given enough information
     if (!defined($first)  || $first  eq '' ||       if (!defined($first)  || $first  eq '' || 
         !defined($last)   || $last   eq '' ||           !defined($last)   || $last   eq '' || 
Line 3187  sub modify_student_enrollment { Line 3184  sub modify_student_enrollment {
                        ['firstname','middlename','lastname', 'generation','id']                         ['firstname','middlename','lastname', 'generation','id']
                        ,$udom,$uname);                         ,$udom,$uname);
   
         foreach (keys(%tmp)) {          #foreach (keys(%tmp)) {
             &logthis("key $_ = ".$tmp{$_});          #    &logthis("key $_ = ".$tmp{$_});
         }          #}
         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');          $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');          $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
         $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');          $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
Line 3198  sub modify_student_enrollment { Line 3195  sub modify_student_enrollment {
     }      }
     my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,      my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
                                                            $first,$middle);                                                             $first,$middle);
     my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.      my $value=&escape($uname.':'.$udom).'='.
               $ENV{'course.'.$cid.'.num'}.':classlist:'.   &escape(join(':',$end,$start,$uid,$usec,$fullname,$type));
                       &escape($uname.':'.$udom).'='.      my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);
                       &escape(join(':',$end,$start,$uid,$usec,$fullname)),  
               $ENV{'course.'.$cid.'.home'});  
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      unless (($reply eq 'ok') || ($reply eq 'delayed')) {
  return 'error: '.$reply;   return 'error: '.$reply;
     }      }
Line 3694  sub EXT { Line 3689  sub EXT {
  my $hashid="$udom:$uname";   my $hashid="$udom:$uname";
  my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,   my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
  'userres');   'userres');
  if (!defined($cached)) {    if (!defined($cached)) {
     my %resourcedata=&get('resourcedata',      my %resourcedata=&dump('resourcedata',$udom,$uname);
   [$courselevelr,$courselevelm,  
    $courselevel],$udom,$uname);  
     $result=\%resourcedata;      $result=\%resourcedata;
     &do_cache(\%userresdatacache,$hashid,$result,'userres');      &do_cache(\%userresdatacache,$hashid,$result,'userres');
  }   }
Line 3846  sub metadata { Line 3839  sub metadata {
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
  my %lcmetacache;   if (! exists($metacache{$uri})) {
       $metacache{$uri}={};
    }
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
Line 3870  sub metadata { Line 3865  sub metadata {
     if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
  $keyroot.='_'.$token->[2]->{'id'};    $keyroot.='_'.$token->[2]->{'id'}; 
     }      }
     if ($lcmetacache{':packages'}) {      if ($metacache{$uri}->{':packages'}) {
  $lcmetacache{':packages'}.=','.$package.$keyroot;   $metacache{$uri}->{':packages'}.=','.$package.$keyroot;
     } else {      } else {
  $lcmetacache{':packages'}=$package.$keyroot;   $metacache{$uri}->{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach (keys %packagetab) {
  my $part=$keyroot;   my $part=$keyroot;
Line 3895  sub metadata { Line 3890  sub metadata {
     if ($subp eq 'display') {      if ($subp eq 'display') {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     $lcmetacache{':'.$unikey.'.part'}=$part;      $metacache{$uri}->{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {      unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
  $lcmetacache{':'.$unikey.'.'.$subp}=$value;   $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($lcmetacache{':'.$unikey.'.default'})) {      if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
  $lcmetacache{':'.$unikey}=   $metacache{$uri}->{':'.$unikey}=
     $lcmetacache{':'.$unikey.'.default'};      $metacache{$uri}->{':'.$unikey.'.default'};
     }      }
  }   }
     }      }
Line 3935  sub metadata { Line 3930  sub metadata {
     foreach (sort(split(/\,/,&metadata($uri,'keys',      foreach (sort(split(/\,/,&metadata($uri,'keys',
        $location,$unikey,         $location,$unikey,
        $depthcount+1)))) {         $depthcount+1)))) {
    $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
  $metathesekeys{$_}=1;   $metathesekeys{$_}=1;
     }      }
  }   }
Line 3945  sub metadata { Line 3941  sub metadata {
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
     $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
  }   }
  my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
  my $default=$lcmetacache{':'.$unikey.'.default'};   my $default=$metacache{$uri}->{':'.$unikey.'.default'};
  if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
  # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
  # as value   # as value
     $lcmetacache{':'.$unikey}=$default;      $metacache{$uri}->{':'.$unikey}=$default;
  } else {   } else {
   # either something interesting inside the tag or default    # either something interesting inside the tag or default
                   # uninteresting                    # uninteresting
     $lcmetacache{':'.$unikey}=$internaltext;      $metacache{$uri}->{':'.$unikey}=$internaltext;
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 3966  sub metadata { Line 3962  sub metadata {
     }      }
  }   }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($lcmetacache{':copyright'} eq 'custom') {   if ($metacache{$uri}->{':copyright'} eq 'custom') {
   
     #      #
     # Importing a rights file here      # Importing a rights file here
     #      #
     unless ($depthcount) {      unless ($depthcount) {
  my $location=$lcmetacache{':customdistributionfile'};   my $location=$metacache{$uri}->{':customdistributionfile'};
  my $dir=$filename;   my $dir=$filename;
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  foreach (sort(split(/\,/,&metadata($uri,'keys',   foreach (sort(split(/\,/,&metadata($uri,'keys',
    $location,'_rights',     $location,'_rights',
    $depthcount+1)))) {     $depthcount+1)))) {
       $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
     $metathesekeys{$_}=1;      $metathesekeys{$_}=1;
  }   }
     }      }
  }   }
  $lcmetacache{':keys'}=join(',',keys %metathesekeys);   $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);   &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
  $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache(\%metacache,$uri,\%lcmetacache,'meta');   &do_cache(\%metacache,$uri,$metacache{$uri},'meta');
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri}->{':'.$what};      return $metacache{$uri}->{':'.$what};
Removed from v.1.452  
changed lines
  Added in v.1.458

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