--- loncom/lonnet/perl/lonnet.pm 2003/12/02 19:35:26 1.451 +++ loncom/lonnet/perl/lonnet.pm 2003/12/09 16:22:06 1.458 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.451 2003/12/02 19:35:26 albertel Exp $ +# $Id: lonnet.pm,v 1.458 2003/12/09 16:22:06 matthew Exp $ # # Copyright Michigan State University Board of Trustees # @@ -506,38 +506,16 @@ sub changepass { sub queryauthenticate { my ($uname,$udom)=@_; - if (($perlvar{'lonRole'} eq 'library') && - ($udom eq $perlvar{'lonDefDomain'})) { - my $answer=reply("encrypt:currentauth:$udom:$uname", - $perlvar{'lonHostID'}); - 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'; - } - } - } - - 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'; - } - } - } + my $uhome=&homeserver($uname,$udom); + if (!$uhome) { + &logthis("User $uname at $udom is unknown when looking for authentication mechanism"); + return 'no_host'; + } + my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome); + if ($answer =~ /^(unknown_user|refused|con_lost)/) { + &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); } - &logthis("User $uname at $udom lacks an authentication mechanism"); - return 'no_host'; + return $answer; } # --------- Try to authenticate user from domain's lib servers (first this one) @@ -848,10 +826,14 @@ sub getsection { return '-1'; } + +my $disk_caching_disabled=1; + sub devalidate_cache { my ($cache,$id,$name) = @_; delete $$cache{$id.'.time'}; delete $$cache{$id}; + if ($disk_caching_disabled) { return; } my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; open(DB,"$filename.lock"); flock(DB,LOCK_EX); @@ -907,6 +889,7 @@ sub do_cache { sub save_cache_item { my ($cache,$name,$id)=@_; + if ($disk_caching_disabled) { return; } my $starttime=&Time::HiRes::time(); # &logthis("Saving :$name:$id"); my %hash; @@ -936,6 +919,7 @@ EVALBLOCK sub load_cache_item { my ($cache,$name,$id)=@_; + if ($disk_caching_disabled) { return; } my $starttime=&Time::HiRes::time(); # &logthis("Before Loading $name for $id size is ".scalar(%$cache)); my %hash; @@ -1335,8 +1319,15 @@ sub flushcourselogs { # Writes to the dynamic metadata of resources to get hit counts, etc. # foreach my $entry (keys(%accesshash)) { - my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); - if ($type eq 'count'){ + if ($entry =~ /___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 (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/); my %temphash=($url => $value); @@ -1351,6 +1342,7 @@ sub flushcourselogs { } } } else { + my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); my %temphash=($entry => $accesshash{$entry}); if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { delete $accesshash{$entry}; @@ -1391,8 +1383,7 @@ sub courselog { } else { $courselogs{$ENV{'request.course.id'}}.=$what; } -# if (length($courselogs{$ENV{'request.course.id'}})>4048) { - if (length($courselogs{$ENV{'request.course.id'}})>48) { + if (length($courselogs{$ENV{'request.course.id'}})>4048) { &flushcourselogs(); } } @@ -1414,6 +1405,7 @@ sub courseacclog { sub countacc { my $url=&declutter(shift); + return if (! defined($url) || $url eq ''); unless ($ENV{'request.course.id'}) { return ''; } $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; @@ -3138,10 +3130,11 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome,$email)=@_; - my $cid=''; - unless ($cid=$ENV{'request.course.id'}) { - return 'not_in_class'; + $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_; + if (!$cid) { + unless ($cid=$ENV{'request.course.id'}) { + return 'not_in_class'; + } } # --------------------------------------------------------------- Make the user my $reply=&modifyuser @@ -3151,24 +3144,34 @@ sub modifystudent { # This will cause &modify_student_enrollment to get the uid from the # students environment $uid = undef if (!$forceid); - $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle, - $last,$gene,$usec,$end,$start); + $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, + $gene,$usec,$end,$start,$type,$cid); return $reply; } sub modify_student_enrollment { - my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_; - # Get the course id from the environment - my $cid=''; - unless ($cid=$ENV{'request.course.id'}) { - return 'not_in_class'; + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, + $cid) = @_; + my ($cdom,$cnum,$chome); + if (!$cid) { + 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 my $uhome=&homeserver($uname,$udom); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such user'; } - # # Get student data if we were not given enough information if (!defined($first) || $first eq '' || !defined($last) || $last eq '' || @@ -3181,9 +3184,9 @@ sub modify_student_enrollment { ['firstname','middlename','lastname', 'generation','id'] ,$udom,$uname); - foreach (keys(%tmp)) { - &logthis("key $_ = ".$tmp{$_}); - } + #foreach (keys(%tmp)) { + # &logthis("key $_ = ".$tmp{$_}); + #} $first = $tmp{'firstname'} if (!defined($first) || $first eq ''); $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); $last = $tmp{'lastname'} if (!defined($last) || $last eq ''); @@ -3192,11 +3195,9 @@ sub modify_student_enrollment { } my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, $first,$middle); - my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. - $ENV{'course.'.$cid.'.num'}.':classlist:'. - &escape($uname.':'.$udom).'='. - &escape(join(':',$end,$start,$uid,$usec,$fullname)), - $ENV{'course.'.$cid.'.home'}); + my $value=&escape($uname.':'.$udom).'='. + &escape(join(':',$end,$start,$uid,$usec,$fullname,$type)); + my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; } @@ -3688,10 +3689,8 @@ sub EXT { my $hashid="$udom:$uname"; my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, 'userres'); - if (!defined($cached)) { - my %resourcedata=&get('resourcedata', - [$courselevelr,$courselevelm, - $courselevel],$udom,$uname); + if (!defined($cached)) { + my %resourcedata=&dump('resourcedata',$udom,$uname); $result=\%resourcedata; &do_cache(\%userresdatacache,$hashid,$result,'userres'); } @@ -3840,7 +3839,9 @@ sub metadata { # # Is this a recursive call for a library? # - my %lcmetacache; + if (! exists($metacache{$uri})) { + $metacache{$uri}={}; + } if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; @@ -3864,10 +3865,10 @@ sub metadata { if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } - if ($lcmetacache{':packages'}) { - $lcmetacache{':packages'}.=','.$package.$keyroot; + if ($metacache{$uri}->{':packages'}) { + $metacache{$uri}->{':packages'}.=','.$package.$keyroot; } else { - $lcmetacache{':packages'}=$package.$keyroot; + $metacache{$uri}->{':packages'}=$package.$keyroot; } foreach (keys %packagetab) { my $part=$keyroot; @@ -3889,14 +3890,14 @@ sub metadata { if ($subp eq 'display') { $value.=' [Part: '.$part.']'; } - $lcmetacache{':'.$unikey.'.part'}=$part; + $metacache{$uri}->{':'.$unikey.'.part'}=$part; $metathesekeys{$unikey}=1; - unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) { - $lcmetacache{':'.$unikey.'.'.$subp}=$value; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; } - if (defined($lcmetacache{':'.$unikey.'.default'})) { - $lcmetacache{':'.$unikey}= - $lcmetacache{':'.$unikey.'.default'}; + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; } } } @@ -3929,6 +3930,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } @@ -3939,18 +3941,18 @@ sub metadata { } $metathesekeys{$unikey}=1; foreach (@{$token->[3]}) { - $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; } 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*$/) { # only ws inside the tag, and not in default, so use default # as value - $lcmetacache{':'.$unikey}=$default; + $metacache{$uri}->{':'.$unikey}=$default; } else { # either something interesting inside the tag or default # uninteresting - $lcmetacache{':'.$unikey}=$internaltext; + $metacache{$uri}->{':'.$unikey}=$internaltext; } # end of not-a-package not-a-library import } @@ -3960,27 +3962,28 @@ sub metadata { } } # are there custom rights to evaluate - if ($lcmetacache{':copyright'} eq 'custom') { + if ($metacache{$uri}->{':copyright'} eq 'custom') { # # Importing a rights file here # unless ($depthcount) { - my $location=$lcmetacache{':customdistributionfile'}; + my $location=$metacache{$uri}->{':customdistributionfile'}; my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); foreach (sort(split(/\,/,&metadata($uri,'keys', $location,'_rights', $depthcount+1)))) { + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } } - $lcmetacache{':keys'}=join(',',keys %metathesekeys); - &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri); - $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache(\%metacache,$uri,\%lcmetacache,'meta'); + $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); + $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); # this is the end of "was not already recently cached } return $metacache{$uri}->{':'.$what};