--- loncom/lonnet/perl/lonnet.pm 2003/05/10 23:00:39 1.373 +++ loncom/lonnet/perl/lonnet.pm 2003/09/25 19:47:13 1.422 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.373 2003/05/10 23:00:39 www Exp $ +# $Id: lonnet.pm,v 1.422 2003/09/25 19:47:13 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -76,13 +76,16 @@ qw(%perlvar %hostname %homecache %badSer %libserv %pr %prp %metacache %packagetab %titlecache %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache - %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); + %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def + %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); + use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); use HTML::LCParser; use Fcntl qw(:flock); use Apache::loncoursedata; +use Apache::lonlocal; my $readit; @@ -244,6 +247,40 @@ sub critical { return $answer; } +# +# -------------- Remove all key from the env that start witha lowercase letter +# (Which is always a lon-capa value) + +sub cleanenv { +# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; } +# unless (&Apache::exists_config_define("MODPERL2")) { return; } + foreach my $key (keys(%ENV)) { + if ($key =~ /^[a-z]/) { + delete($ENV{$key}); + } + } +} + +# ------------------------------------------- Transfer profile into environment + +sub transfer_profile_to_env { + my ($lonidsdir,$handle)=@_; + my @profile; + { + my $idf=Apache::File->new("$lonidsdir/$handle.id"); + flock($idf,LOCK_SH); + @profile=<$idf>; + $idf->close(); + } + my $envi; + for ($envi=0;$envi<=$#profile;$envi++) { + chomp($profile[$envi]); + my ($envname,$envvalue)=split(/=/,$profile[$envi]); + $ENV{$envname} = $envvalue; + } + $ENV{'user.environment'} = "$lonidsdir/$handle.id"; +} + # ---------------------------------------------------------- Append Environment sub appenv { @@ -357,8 +394,8 @@ sub userload { my $curtime=time; while ($filename=readdir(LONIDS)) { if ($filename eq '.' || $filename eq '..') {next;} - my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8]; - if ($curtime-$atime < 3600) { $numusers++; } + my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; + if ($curtime-$mtime < 3600) { $numusers++; } } closedir(LONIDS); } @@ -404,15 +441,27 @@ sub spareserver { my $lowestserver=$loadpercent > $userloadpercent? $loadpercent : $userloadpercent; foreach $tryserver (keys %spareid) { - my $loadans=reply('load',$tryserver); - my $userloadans=reply('userload',$tryserver); - if ($userloadans !~ /\d/) { $userloadans=0; } - my $answer=$loadans > $userloadans? - $loadans : $userloadans; - if (($answer =~ /\d/) && ($answer<$lowestserver)) { - $spareserver="http://$hostname{$tryserver}"; - $lowestserver=$answer; - } + my $loadans=reply('load',$tryserver); + my $userloadans=reply('userload',$tryserver); + if ($loadans !~ /\d/ && $userloadans !~ /\d/) { + next; #didn't get a number from the server + } + my $answer; + if ($loadans =~ /\d/) { + if ($userloadans =~ /\d/) { + #both are numbers, pick the bigger one + $answer=$loadans > $userloadans? + $loadans : $userloadans; + } else { + $answer = $loadans; + } + } else { + $answer = $userloadans; + } + if (($answer =~ /\d/) && ($answer<$lowestserver)) { + $spareserver="http://$hostname{$tryserver}"; + $lowestserver=$answer; + } } return $spareserver; } @@ -799,8 +848,39 @@ sub getsection { return '-1'; } +sub devalidate_cache { + my ($cache,$id) = @_; + delete $$cache{$id.'.time'}; + delete $$cache{$id}; +} + +sub is_cached { + my ($cache,$id,$time) = @_; + if (!$time) { $time=300; } + if (!exists($$cache{$id.'.time'})) { + return (undef,undef); + } else { + if (time-$$cache{$id.'.time'}>$time) { + &devalidate_cache($cache,$id); + return (undef,undef); + } + } + return ($$cache{$id},1); +} + +sub do_cache { + my ($cache,$id,$value) = @_; + $$cache{$id.'.time'}=time; + # do_cache implictly return the set value + $$cache{$id}=$value; +} + sub usection { my ($udom,$unam,$courseid)=@_; + my $hashid="$udom:$unam:$courseid"; + + my ($result,$cached)=&is_cached(\%usectioncache,$hashid); + if (defined($cached)) { return $result; } $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', @@ -819,10 +899,12 @@ sub usection { if ($end) { if ($now>$end) { $notactive=1; } } - unless ($notactive) { return $section; } + unless ($notactive) { + return &do_cache(\%usectioncache,$hashid,$section); + } } } - return '-1'; + return &do_cache(\%usectioncache,$hashid,'-1'); } # ------------------------------------- Read an entry from a user's environment @@ -962,9 +1044,9 @@ sub repcopy { # ------------------------------------------------ Get server side include body sub ssi_body { - my $filelink=shift; + my ($filelink,%form)=@_; my $output=($filelink=~/^http\:/?&externalssi($filelink): - &ssi($filelink)); + &ssi($filelink,%form)); $output=~s/^.*\]*\>//si; $output=~s/\<\/body\s*\>.*$//si; $output=~ @@ -1196,7 +1278,7 @@ sub courseacclog { my $fnsymb=shift; unless ($ENV{'request.course.id'}) { return ''; } my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; - if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) { + if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { $what.=':POST'; foreach (keys %ENV) { if ($_=~/^form\.(.*)/) { @@ -1264,6 +1346,53 @@ sub get_course_adv_roles { return %returnhash; } +sub get_my_roles { + my ($uname,$udom)=@_; + unless (defined($uname)) { $uname=$ENV{'user.name'}; } + unless (defined($udom)) { $udom=$ENV{'user.domain'}; } + my %dumphash= + &dump('nohist_userroles',$udom,$uname); + my %returnhash=(); + my $now=time; + foreach (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + if (($tstart) && ($tstart<0)) { next; } + if (($tend) && ($tend<$now)) { next; } + if (($tstart) && ($now<$tstart)) { next; } + my ($role,$username,$domain,$section)=split(/\:/,$_); + $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + } + return %returnhash; +} + +# ----------------------------------------------------- Frontpage Announcements +# +# + +sub postannounce { + my ($server,$text)=@_; + unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } + unless ($text=~/\w/) { $text=''; } + return &reply('setannounce:'.&escape($text),$server); +} + +sub getannounce { + if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { + my $announcement=''; + while (<$fh>) { $announcement .=$_; } + $fh->close(); + if ($announcement=~/\w/) { + return + ''. + '
'.$announcement.'
'; + } else { + return ''; + } + } else { + return ''; + } +} + # ---------------------------------------------------------- Course ID routines # Deal with domain's nohist_courseid.db files # @@ -1405,19 +1534,19 @@ sub devalidate { my ($symb,$uname,$udom)=@_; my $cid=$ENV{'request.course.id'}; if ($cid) { -# delete the stored spreadsheets for -# - the student level sheet of this user in course's homespace -# - the assessment level sheet for this resource -# for this user in user's homespace + # delete the stored spreadsheets for + # - the student level sheet of this user in course's homespace + # - the assessment level sheet for this resource + # for this user in user's homespace my $key=$uname.':'.$udom.':'; my $status= &del('nohist_calculatedsheets', - [$key.'studentcalc'], + [$key.'studentcalc:'], $ENV{'course.'.$cid.'.domain'}, $ENV{'course.'.$cid.'.num'}) .' '. &del('nohist_calculatedsheets_'.$cid, - [$key.'assesscalc:'.$symb]); + [$key.'assesscalc:'.$symb],$udom,$uname); unless ($status eq 'ok ok') { &logthis('Could not devalidate spreadsheet '. $uname.' at '.$udom.' for '. @@ -1623,7 +1752,7 @@ sub tmpreset { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } + if (!$symb) { $symb= $ENV{'request.url'}; } } $symb=escape($symb); @@ -1916,14 +2045,14 @@ sub rolesinit { my ($tdummy,$tdomain,$trest)=split(/\//,$area); if ($trole =~ /^cr\//) { my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); - my $homsvr=homeserver($rauthor,$rdomain); + my $homsvr=homeserver($rauthor,$rdomain); if ($hostname{$homsvr} ne '') { - my $roledef= - reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", - $homsvr); - if (($roledef ne 'con_lost') && ($roledef ne '')) { + my ($rdummy,$roledef)= + &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); + + if (($rdummy ne 'con_lost') && ($roledef ne '')) { my ($syspriv,$dompriv,$coursepriv)= - split(/\_/,unescape($roledef)); + split(/\_/,$roledef); if (defined($syspriv)) { $allroles{'cm./'}.=':'.$syspriv; $allroles{$spec.'./'}.=':'.$syspriv; @@ -2057,6 +2186,21 @@ sub dump { return %returnhash; } +# -------------------------------------------------------------- keys interface + +sub getkeys { + my ($namespace,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); + my @keyarray=(); + foreach (split(/\&/,$rep)) { + push (@keyarray,&unescape($_)); + } + return @keyarray; +} + # --------------------------------------------------------------- currentdump sub currentdump { my ($courseid,$sdom,$sname)=@_; @@ -2189,6 +2333,9 @@ sub customaccess { $access=($effect eq 'allow'); last; } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } } return $access; } @@ -2201,6 +2348,7 @@ sub allowed { my $orguri=$uri; $uri=&declutter($uri); + if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } # Free bre access to adm and meta resources if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { @@ -2492,7 +2640,10 @@ sub is_on_map { if ($match) { return (1,$1); } else { - return (0,0); + my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/); + $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ + /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/; + return (0,$2,$pathname.'/'.$1); } } @@ -2501,7 +2652,7 @@ sub is_on_map { sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; - foreach (split('/',$sysrole)) { + foreach (split(':',$sysrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } if ($pr{'cr:s'}=~/$crole\&/) { @@ -2510,7 +2661,7 @@ sub definerole { } } } - foreach (split('/',$domrole)) { + foreach (split(':',$domrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } if ($pr{'cr:d'}=~/$crole\&/) { @@ -2519,7 +2670,7 @@ sub definerole { } } } - foreach (split('/',$courole)) { + foreach (split(':',$courole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } if ($pr{'cr:c'}=~/$crole\&/) { @@ -2622,7 +2773,7 @@ sub userlog_query { sub plaintext { my $short=shift; - return $prp{$short}; + return &mt($prp{$short}); } # ----------------------------------------------------------------- Assign Role @@ -2631,7 +2782,9 @@ sub assignrole { my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; my $mrole; if ($role =~ /^cr\//) { - unless (&allowed('ccr',$url)) { + my $cwosec=$url; + $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); @@ -2712,7 +2865,7 @@ sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, - $forceid, $desiredhome)=@_; + $forceid, $desiredhome, $email)=@_; $udom=~s/\W//g; $uname=~s/\W//g; &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. @@ -2724,7 +2877,8 @@ sub modifyuser { ' in domain '.$ENV{'request.role.domain'}); my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User - if (($uhome eq 'no_host') && ($umode) && ($upass)) { + if (($uhome eq 'no_host') && + (($umode && $upass) || ($umode eq 'localauth'))) { my $unhome=''; if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { $unhome = $desiredhome; @@ -2754,7 +2908,7 @@ sub modifyuser { } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { - return 'error: verify home'; + return 'error: unable verify users home machine.'; } } # End of creation of new user # ---------------------------------------------------------------------- Add ID @@ -2764,7 +2918,8 @@ sub modifyuser { if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) && (!$forceid)) { unless ($uid eq $uidhash{$uname}) { - return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; + return 'error: user id "'.$uid.'" does not match '. + 'current user id "'.$uidhash{$uname}.'".'; } } else { &idput($udom,($uname => $uid)); @@ -2780,10 +2935,17 @@ sub modifyuser { } else { %names = @tmp; } +# +# Make sure to not trash student environment if instructor does not bother +# to supply name and email information +# if ($first) { $names{'firstname'} = $first; } - if ($middle) { $names{'middlename'} = $middle; } + if (defined($middle)) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } - if ($gene) { $names{'generation'} = $gene; } + if (defined($gene)) { $names{'generation'} = $gene; } + if ($email) { $names{'notification'} = $email; + $names{'critnotification'} = $email; } + my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. @@ -2797,7 +2959,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome)=@_; + $end,$start,$forceid,$desiredhome,$email)=@_; my $cid=''; unless ($cid=$ENV{'request.course.id'}) { return 'not_in_class'; @@ -2805,7 +2967,7 @@ sub modifystudent { # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, - $desiredhome); + $desiredhome,$email); unless ($reply eq 'ok') { return $reply; } # This will cause &modify_student_enrollment to get the uid from the # students environment @@ -3040,7 +3202,7 @@ sub dirlist { } my $alldomstr=''; foreach (sort keys %alldom) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; } $alldomstr=~s/:$//; return split(/:/,$alldomstr); @@ -3056,6 +3218,13 @@ sub dirlist { # when it was last modified. It will also return an error of -1 # if an error occurs +## +## FIXME: This subroutine assumes its caller knows something about the +## directory structure of the home server for the student ($root). +## Not a good assumption to make. Since this is for looking up files +## in user directories, the full path should be constructed by lond, not +## whatever machine we request data from. +## sub GetFileTimestamp { my ($studentDomain,$studentName,$filename,$root)=@_; $studentDomain=~s/\W//g; @@ -3064,12 +3233,12 @@ sub GetFileTimestamp { $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; my $proname="$studentDomain/$subdir/$studentName"; $proname .= '/'.$filename; - my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName, - $root); - my $fileStat = $dir[0]; + my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, + $studentName, $root); my @stats = split('&', $fileStat); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { - return $stats[9]; + # @stats contains first the filename, then the stat output + return $stats[10]; # so this is 10 instead of 9. } else { return -1; } @@ -3132,7 +3301,7 @@ sub condval { sub devalidatecourseresdata { my ($coursenum,$coursedomain)=@_; my $hashid=$coursenum.':'.$coursedomain; - delete $courseresdatacache{$hashid.'.time'}; + &devalidate_cache(\%courseresdatacache,$hashid); } # --------------------------------------------------- Course Resourcedata Query @@ -3141,34 +3310,56 @@ sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - my $dodump=0; - if (!defined($courseresdatacache{$hashid.'.time'})) { - $dodump=1; - } else { - if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; } - } - if ($dodump) { + my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid); + unless (defined($cached)) { my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + $result=\%dumpreply; my ($tmp) = keys(%dumpreply); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { - $courseresdatacache{$hashid.'.time'}=time; - $courseresdatacache{$hashid}=\%dumpreply; + &do_cache(\%courseresdatacache,$hashid,$result); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; + } elsif ($tmp =~ /^(error)/) { + $result=undef; + &do_cache(\%courseresdatacache,$hashid,$result); } } foreach my $item (@which) { - if (defined($courseresdatacache{$hashid}->{$item})) { - return $courseresdatacache{$hashid}->{$item}; + if (defined($result->{$item})) { + return $result->{$item}; } } return undef; } -# --------------------------------------------------------- Value of a Variable +# +# EXT resource caching routines +# +sub clear_EXT_cache_status { + &delenv('cache.EXT.'); +} + +sub EXT_cache_status { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { + # We know already the user has no data + return 1; + } else { + return 0; + } +} + +sub EXT_cache_set { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + &appenv($cachename => time); +} + +# --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,)=@_; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb @@ -3176,7 +3367,7 @@ sub EXT { my $publicuser; if (!($uname && $udom)) { (my $cursymb,$courseid,$udom,$uname,$publicuser)= - &Apache::lonxml::whichuser(); + &Apache::lonxml::whichuser($symbparm); if (!$symbparm) { $symbparm=$cursymb; } } else { $courseid=$ENV{'request.course.id'}; @@ -3253,8 +3444,9 @@ sub EXT { } } elsif ($realm eq 'query') { # ---------------------------------------------- pull stuff out of query string - &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]); - return $ENV{'form.'.$space}; + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, + [$spacequalifierrest]); + return $ENV{'form.'.$spacequalifierrest}; } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { @@ -3268,6 +3460,7 @@ sub EXT { return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { + my $section; if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; @@ -3275,17 +3468,20 @@ sub EXT { # ----------------------------------------------------- Cascading lookup scheme if (!$symbparm) { $symbparm=&symbread(); } my $symbp=$symbparm; - my $mapp=(split(/\_\_\_/,$symbp))[0]; + my $mapp=(&decode_symb($symbp))[0]; my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - my $section; if (($ENV{'user.name'} eq $uname) && ($ENV{'user.domain'} eq $udom)) { $section=$ENV{'request.course.sec'}; } else { - $section=&usection($udom,$uname,$courseid); + if (! defined($usection)) { + $section=&usection($udom,$uname,$courseid); + } else { + $section = $usection; + } } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -3297,33 +3493,36 @@ sub EXT { my $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user - #most student don't have any data set, check if there is some data - #every thirty minutes - if (! - (exists($ENV{'cache.studentresdata'}) - && (($ENV{'cache.studentresdata'}+1800) > time))) { - my %resourcedata=&get('resourcedata', - [$courselevelr,$courselevelm,$courselevel], - $udom,$uname); - my ($tmp)=keys(%resourcedata); + #most student don\'t have any data set, check if there is some data + if (! &EXT_cache_status($udom,$uname)) { + my $hashid="$udom:$uname"; + my ($result,$cached)=&is_cached(\%userresdatacache,$hashid); + if (!defined($cached)) { + my %resourcedata=&get('resourcedata', + [$courselevelr,$courselevelm, + $courselevel],$udom,$uname); + $result=\%resourcedata; + } + my ($tmp)=keys(%$result); if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { - if ($resourcedata{$courselevelr}) { - return $resourcedata{$courselevelr}; } - if ($resourcedata{$courselevelm}) { - return $resourcedata{$courselevelm}; } - if ($resourcedata{$courselevel}) { - return $resourcedata{$courselevel}; } + &do_cache(\%userresdatacache,$hashid,$result); + if ($$result{$courselevelr}) { + return $$result{$courselevelr}; } + if ($$result{$courselevelm}) { + return $$result{$courselevelm}; } + if ($$result{$courselevel}) { + return $$result{$courselevel}; } } else { if ($tmp!~/No such file/) { &logthis("WARNING:". " Trying to get resource data for ". $uname." at ".$udom.": ". $tmp.""); + &do_cache(\%userresdatacache,$hashid,undef); } elsif ($tmp=~/error:No such file/) { - $ENV{'cache.studentresdata'}=time; - &appenv(('cache.studentresdata'=> - $ENV{'cache.studentresdata'})); + &EXT_cache_set($udom,$uname); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + &do_cache(\%userresdatacache,$hashid,undef); return $tmp; } } @@ -3355,7 +3554,7 @@ sub EXT { my $filename; if (!$symbparm) { $symbparm=&symbread(); } if ($symbparm) { - $filename=(split(/\_\_\_/,$symbparm))[2]; + $filename=(&decode_symb($symbparm))[2]; } else { $filename=$ENV{'request.filename'}; } @@ -3371,9 +3570,12 @@ sub EXT { my $part=join('_',@parts); if ($part eq '') { $part='0'; } my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm,$udom,$uname); + $symbparm,$udom,$uname,$section,1); if (defined($partgeneral)) { return $partgeneral; } } + if ($recurse) { return undef; } + my $pack_def=&packages_tab_default($filename,$varname); + if (defined($pack_def)) { return $pack_def; } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { @@ -3394,6 +3596,19 @@ sub EXT { return ''; } +sub packages_tab_default { + my ($uri,$varname)=@_; + my (undef,$part,$name)=split(/\./,$varname); + my $packages=&metadata($uri,'packages'); + foreach my $package (split(/,/,$packages)) { + my ($pack_type,$pack_part)=split(/_/,$package,2); + if ($pack_part eq $part) { + return $packagetab{"$pack_type&$name&default"}; + } + } + return undef; +} + sub add_prefix_and_part { my ($prefix,$part)=@_; my $keyroot; @@ -3418,7 +3633,7 @@ sub metadata { $uri=&declutter($uri); # if it is a non metadata possible uri return quickly if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || - ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) { + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/)) { return ''; } my $filename=$uri; @@ -3435,14 +3650,15 @@ sub metadata { if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; - } + } else { + delete($metacache{$uri.':packages'}); + } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring=&getfile(&filelocation('',&clutter($filename))); my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; - delete($metacache{$uri.':packages'}); while ($token=$parser->get_token) { if ($token->[0] eq 'S') { if (defined($token->[2]->{'package'})) { @@ -3462,6 +3678,9 @@ sub metadata { foreach (keys %packagetab) { if ($_=~/^$package\&/) { my ($pack,$name,$subp)=split(/\&/,$_); + # ignore package.tab specified default values + # here &package_tab_default() will fetch those + if ($subp eq 'default') { next; } my $value=$packagetab{$_}; my $part=$keyroot; $part=~s/^\_//; @@ -3469,13 +3688,8 @@ sub metadata { $value.=' [Part: '.$part.']'; } my $unikey='parameter'.$keyroot.'_'.$name; - if ($subp eq 'default') { - $unikey='parameter_0_'.$name; - $metacache{$uri.':'.$unikey.'.part'}='0'; - } else { - $metacache{$uri.':'.$unikey.'.part'}=$part; - $metathesekeys{$unikey}=1; - } + $metacache{$uri.':'.$unikey.'.part'}=$part; + $metathesekeys{$unikey}=1; unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { $metacache{$uri.':'.$unikey.'.'.$subp}=$value; } @@ -3608,8 +3822,9 @@ sub gettitle { unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } return &metadata($urlsymb,'title'); } - if ($titlecache{$symb}) { return $titlecache{$symb}; } - my ($map,$resid,$url)=split(/\_\_\_/,$symb); + my ($result,$cached)=&is_cached(\%titlecache,$symb,600); + if (defined($cached)) { return $result; } + my ($map,$resid,$url)=&decode_symb($symb); my $title=''; my %bighash; if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', @@ -3620,8 +3835,7 @@ sub gettitle { } $title=~s/\&colon\;/\:/gs; if ($title) { - $titlecache{$symb}=$title; - return $title; + return &do_cache(\%titlecache,$symb,$title); } else { return &metadata($urlsymb,'title'); } @@ -3655,7 +3869,7 @@ sub symbverify { # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } # check URL part - my ($map,$resid,$url)=split(/\_\_\_/,$symb); + my ($map,$resid,$url)=&decode_symb($symb); unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } $symb=&symbclean($symb); @@ -3698,6 +3912,23 @@ sub symbclean { return $symb; } +# ---------------------------------------------- Split symb to find map and url + +sub decode_symb { + my ($map,$resid,$url)=split(/\_\_\_/,shift); + return (&fixversion($map),$resid,&fixversion($url)); +} + +sub fixversion { + my $fn=shift; + if ($fn=~/^(adm|uploaded|public)/) { return $fn; } + my ($match,$cond,$versioned)=&is_on_map($fn); + unless ($match) { + $fn=$versioned; + } + return $fn; +} + # ------------------------------------------------------ Return symb list entry sub symbread { @@ -3997,6 +4228,12 @@ sub unescape { return $str; } +sub mod_perl_version { + if (defined($perlvar{'MODPERL2'})) { + return 2; + } + return 1; +} # ================================================================ Main Program sub goodbye { @@ -4041,13 +4278,19 @@ BEGIN { %domain_auth_arg_def = (); if ($fh) { while (<$fh>) { - next if /^\#/; + next if (/^(\#|\s*$)/); +# next if /^\#/; chomp; - my ($domain, $domain_description, $def_auth, $def_auth_arg) - = split(/:/,$_,4); - $domain_auth_def{$domain}=$def_auth; + my ($domain, $domain_description, $def_auth, $def_auth_arg, + $def_lang, $city, $longi, $lati) = split(/:/,$_); + $domain_auth_def{$domain}=$def_auth; $domain_auth_arg_def{$domain}=$def_auth_arg; - $domaindescription{$domain}=$domain_description; + $domaindescription{$domain}=$domain_description; + $domain_lang_def{$domain}=$def_lang; + $domain_city{$domain}=$city; + $domain_longi{$domain}=$longi; + $domain_lati{$domain}=$lati; + # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); } @@ -4184,45 +4427,125 @@ being set. =back -=head1 INTRODUCTION +=head1 OVERVIEW -This module provides subroutines which interact with the -lonc/lond (TCP) network layer of LON-CAPA. And Can be used to ask about -- classes -- users -- resources +lonnet provides subroutines which interact with the +lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask +about classes, users, and resources. For many of these objects you can also use this to store data about them or modify them in various ways. -This is part of the LearningOnline Network with CAPA project -described at http://www.lon-capa.org. +=head2 Symbs -=head1 RETURN MESSAGES +To identify a specific instance of a resource, LON-CAPA uses symbols +or "symbs"X. These identifiers are built from the URL of the +map, the resource number of the resource in the map, and the URL of +the resource itself. The latter is somewhat redundant, but might help +if maps change. -=over 4 +An example is -=item * + msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem -con_lost : unable to contact remote host +The respective map entry is -=item * + + -con_delayed : unable to contact remote host, message will be delivered -when the connection is brought back up +Symbs are used by the random number generator, as well as to store and +restore data specific to a certain instance of for example a problem. -=item * +=head2 Storing And Retrieving Data -con_failed : unable to contact remote host and unable to save message -for later delivery +XXXThree of the most important functions +in C are C<&Apache::lonnet::cstore()>, +C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which +is is the non-critical message twin of cstore. These functions are for +handlers to store a perl hash to a user's permanent data space in an +easy manner, and to retrieve it again on another call. It is expected +that a handler would use this once at the beginning to retrieve data, +and then again once at the end to send only the new data back. -=item * +The data is stored in the user's data directory on the user's +homeserver under the ID of the course. -error: : an error a occured, a description of the error follows the : +The hash that is returned by restore will have all of the previous +value for all of the elements of the hash. -=item * +Example: + + #creating a hash + my %hash; + $hash{'foo'}='bar'; + + #storing it + &Apache::lonnet::cstore(\%hash); + + #changing a value + $hash{'foo'}='notbar'; + + #adding a new value + $hash{'bar'}='foo'; + &Apache::lonnet::cstore(\%hash); + + #retrieving the hash + my %history=&Apache::lonnet::restore(); + + #print the hash + foreach my $key (sort(keys(%history))) { + print("\%history{$key} = $history{$key}"); + } + +Will print out: + + %history{1:foo} = bar + %history{1:keys} = foo:timestamp + %history{1:timestamp} = 990455579 + %history{2:bar} = foo + %history{2:foo} = notbar + %history{2:keys} = foo:bar:timestamp + %history{2:timestamp} = 990455580 + %history{bar} = foo + %history{foo} = notbar + %history{timestamp} = 990455580 + %history{version} = 2 + +Note that the special hash entries C, C and +C were added to the hash. C will be equal to the +total number of versions of the data that have been stored. The +C attribute will be the UNIX time the hash was +stored. C is available in every historical section to list which +keys were added or changed at a specific historical revision of a +hash. + +B: do not store the hash that restore returns directly. This +will cause a mess since it will restore the historical keys as if the +were new keys. I.E. 1:foo will become 1:1:foo etc. + +Calling convention: + + my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); + &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); + +For more detailed information, see lonnet specific documentation. + +=head1 RETURN MESSAGES + +=over 4 -no_such_host : unable to fund a host associated with the user/domain +=item * B: unable to contact remote host + +=item * B: unable to contact remote host, message will be delivered +when the connection is brought back up + +=item * B: unable to contact remote host and unable to save message +for later delivery + +=item * B: an error a occured, a description of the error follows the : + +=item * B: unable to fund a host associated with the user/domain that was requested =back @@ -4233,15 +4556,18 @@ that was requested =over 4 -=item * - -appenv(%hash) : the value of %hash is written to the user envirnoment -file, and will be restored for each access this user makes during this -session, also modifies the %ENV for the current process +=item * +X +B: the value of %hash is written to +the user envirnoment file, and will be restored for each access this +user makes during this session, also modifies the %ENV for the current +process =item * - -delenv($regexp) : removes all items from the session environment file that matches the regular expression in $regexp. The values are also delted from the current processes %ENV. +X +B: removes all items from the session +environment file that matches the regular expression in $regexp. The +values are also delted from the current processes %ENV. =back @@ -4250,50 +4576,51 @@ delenv($regexp) : removes all items from =over 4 =item * - -queryauthenticate($uname,$udom) : try to determine user's current +X +B: try to determine user's current authentication scheme =item * - -authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib -servers (first use the current one), $upass should be the users password +X +B: try to +authenticate user from domain's lib servers (first use the current +one). C<$upass> should be the users password. =item * - -homeserver($uname,$udom) : find the server which has the user's -directory and files (there must be only one), this caches the answer, -and also caches if there is a borken connection. +X +B: find the server which has +the user's directory and files (there must be only one), this caches +the answer, and also caches if there is a borken connection. =item * - -idget($udom,@ids) : find the usernames behind a list of IDs (IDs are a -unique resource in a domain, there must be only 1 ID per username, and -only 1 username per ID in a specific domain) (returns hash: -id=>name,id=>name) +X +B: find the usernames behind a list of IDs +(IDs are a unique resource in a domain, there must be only 1 ID per +username, and only 1 username per ID in a specific domain) (returns +hash: id=>name,id=>name) =item * - -idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash: -name=>id,name=>id) +X +B: find the IDs behind a list of +usernames (returns hash: name=>id,name=>id) =item * - -idput($udom,%ids) : store away a list of names and associated IDs +X +B: store away a list of names and associated IDs =item * - -rolesinit($udom,$username,$authhost) : get user privileges +X +B: get user privileges =item * - -usection($udom,$uname,$cname) : finds the section of student in the +X +B: finds the section of student in the course $cname, return section name/number or '' for "not in course" and '-1' for "no section" =item * - -userenvironment($udom,$uname,@what) : gets the values of the keys +X +B: gets the values of the keys passed in @what from the requested user's environment, returns a hash =back