--- loncom/lonnet/perl/lonnet.pm 2003/08/12 19:46:04 1.399 +++ loncom/lonnet/perl/lonnet.pm 2003/10/04 02:27:02 1.425 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.399 2003/08/12 19:46:04 www Exp $ +# $Id: lonnet.pm,v 1.425 2003/10/04 02:27:02 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -76,14 +76,18 @@ 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; +use Storable qw(lock_store lock_nstore lock_retrieve); +use Time::HiRes(); my $readit; # --------------------------------------------------------------------- Logging @@ -243,6 +247,20 @@ 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 @@ -377,8 +395,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); } @@ -424,15 +442,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; } @@ -819,8 +849,96 @@ sub getsection { return '-1'; } +sub devalidate_cache { + my ($cache,$id) = @_; + delete $$cache{$id.'.time'}; + delete $$cache{$id}; +} + +sub is_cached { + my ($cache,$id,$name,$time) = @_; + if (!$time) { $time=300; } + if (!exists($$cache{$id.'.time'})) { + &load_cache($cache,$name); + } + if (!exists($$cache{$id.'.time'})) { +# &logthis("Didn't find $id"); + return (undef,undef); + } else { + if (time-($$cache{$id.'.time'})>$time) { +# &logthis("Devailidating $id"); + &devalidate_cache($cache,$id); + return (undef,undef); + } + } + return ($$cache{$id},1); +} + +sub do_cache { + my ($cache,$id,$value,$name) = @_; + $$cache{$id.'.time'}=time; + $$cache{$id}=$value; + &save_cache($cache,$name); + # do_cache implictly return the set value + $$cache{$id}; +} + +sub save_cache { + my ($cache,$name)=@_; +# my $starttime=&Time::HiRes::time(); +# &logthis("Saving :$name:"); + eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); + if ($@) { &logthis("lock_store threw a die ".$@); } +# &logthis("save_cache took ".(&Time::HiRes::time()-$starttime)); +} + +sub load_cache { + my ($cache,$name)=@_; +# my $starttime=&Time::HiRes::time(); +# &logthis("Before Loading $name size is ".scalar(%$cache)); + my $tmpcache; + eval { + $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); + }; + if ($@) { &logthis("lock_retreive threw a die ".$@); return; } + if (!%$cache) { + my $count; + while (my ($key,$value)=each(%$tmpcache)) { + $count++; + $$cache{$key}=$value; + } +# &logthis("Initial load: $count"); + } else { + my $key; + my $count; + while ($key=each(%$tmpcache)) { + if ($key !~/^(.*)\.time$/) { next; } + my $name=$1; + if (exists($$cache{$key})) { + if ($$tmpcache{$key} >= $$cache{$key}) { + $$cache{$key}=$$tmpcache{$key}; + $$cache{$name}=$$tmpcache{$name}; + } else { +# &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!"); + } + } else { + $count++; + $$cache{$key}=$$tmpcache{$key}; + $$cache{$name}=$$tmpcache{$name}; + } + } +# &logthis("Additional load: $count"); + } +# &logthis("After Loading $name size is ".scalar(%$cache)); +# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime)); +} + sub usection { my ($udom,$unam,$courseid)=@_; + my $hashid="$udom:$unam:$courseid"; + + my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection'); + if (defined($cached)) { return $result; } $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', @@ -839,10 +957,12 @@ sub usection { if ($end) { if ($now>$end) { $notactive=1; } } - unless ($notactive) { return $section; } + unless ($notactive) { + return &do_cache(\%usectioncache,$hashid,$section,'usection'); + } } } - return '-1'; + return &do_cache(\%usectioncache,$hashid,'-1','usection'); } # ------------------------------------- Read an entry from a user's environment @@ -1216,7 +1336,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\.(.*)/) { @@ -1284,6 +1404,25 @@ 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 # # @@ -2105,6 +2244,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)=@_; @@ -2124,27 +2278,7 @@ sub currentdump { return if ($tmp[0] =~ /^(error:|no_such_host)/); my %hash = @tmp; @tmp=(); - # Code ripped from lond, essentially. The only difference - # here is the unescaping done by lonnet::dump(). Conceivably - # we might run in to problems with parameter names =~ /^v\./ - while (my ($key,$value) = each(%hash)) { - my ($v,$symb,$param) = split(/:/,$key); - next if ($v eq 'version' || $symb eq 'keys'); - next if (exists($returnhash{$symb}) && - exists($returnhash{$symb}->{$param}) && - $returnhash{$symb}->{'v.'.$param} > $v); - $returnhash{$symb}->{$param}=$value; - $returnhash{$symb}->{'v.'.$param}=$v; - } - # - # Remove all of the keys in the hashes which keep track of - # the version of the parameter. - while (my ($symb,$param_hash) = each(%returnhash)) { - # use a foreach because we are going to delete from the hash. - foreach my $key (keys(%$param_hash)) { - delete($param_hash->{$key}) if ($key =~ /^v\./); - } - } + %returnhash = %{&convert_dump_to_currentdump(\%hash)}; } else { my @pairs=split(/\&/,$rep); foreach (@pairs) { @@ -2157,6 +2291,33 @@ sub currentdump { return %returnhash; } +sub convert_dump_to_currentdump{ + my %hash = %{shift()}; + my %returnhash; + # Code ripped from lond, essentially. The only difference + # here is the unescaping done by lonnet::dump(). Conceivably + # we might run in to problems with parameter names =~ /^v\./ + while (my ($key,$value) = each(%hash)) { + my ($v,$symb,$param) = split(/:/,$key); + next if ($v eq 'version' || $symb eq 'keys'); + next if (exists($returnhash{$symb}) && + exists($returnhash{$symb}->{$param}) && + $returnhash{$symb}->{'v.'.$param} > $v); + $returnhash{$symb}->{$param}=$value; + $returnhash{$symb}->{'v.'.$param}=$v; + } + # + # Remove all of the keys in the hashes which keep track of + # the version of the parameter. + while (my ($symb,$param_hash) = each(%returnhash)) { + # use a foreach because we are going to delete from the hash. + foreach my $key (keys(%$param_hash)) { + delete($param_hash->{$key}) if ($key =~ /^v\./); + } + } + return \%returnhash; +} + # --------------------------------------------------------------- put interface sub put { @@ -2237,6 +2398,9 @@ sub customaccess { $access=($effect eq 'allow'); last; } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } } return $access; } @@ -2541,7 +2705,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); } } @@ -2671,7 +2838,7 @@ sub userlog_query { sub plaintext { my $short=shift; - return $prp{$short}; + return &mt($prp{$short}); } # ----------------------------------------------------------------- Assign Role @@ -2775,7 +2942,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; @@ -3115,6 +3283,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; @@ -3191,7 +3366,7 @@ sub condval { sub devalidatecourseresdata { my ($coursenum,$coursedomain)=@_; my $hashid=$coursenum.':'.$coursedomain; - delete $courseresdatacache{$hashid.'.time'}; + &devalidate_cache(\%courseresdatacache,$hashid); } # --------------------------------------------------- Course Resourcedata Query @@ -3200,25 +3375,23 @@ 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,'courseres'); + 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,'courseres'); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; + } elsif ($tmp =~ /^(error)/) { + $result=undef; + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); } } foreach my $item (@which) { - if (defined($courseresdatacache{$hashid}->{$item})) { - return $courseresdatacache{$hashid}->{$item}; + if (defined($result->{$item})) { + return $result->{$item}; } } return undef; @@ -3360,7 +3533,7 @@ 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; @@ -3386,19 +3559,25 @@ sub EXT { # ----------------------------------------------------------- first, check user #most student don\'t have any data set, check if there is some data - #every thirty minutes if (! &EXT_cache_status($udom,$uname)) { - my %resourcedata=&get('resourcedata', - [$courselevelr,$courselevelm,$courselevel], - $udom,$uname); - my ($tmp)=keys(%resourcedata); + my $hashid="$udom:$uname"; + my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, + 'userres'); + if (!defined($cached)) { + my %resourcedata=&get('resourcedata', + [$courselevelr,$courselevelm, + $courselevel],$udom,$uname); + $result=\%resourcedata; + &do_cache(\%userresdatacache,$hashid,$result,'userres'); + } + 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}; } + 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:". @@ -3439,7 +3618,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'}; } @@ -3514,11 +3693,11 @@ sub add_prefix_and_part { sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; - $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 =~ /^~/) || + ($uri =~ m|home/[^/]+/public_html/|)) { return ''; } my $filename=$uri; @@ -3535,14 +3714,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'})) { @@ -3706,14 +3886,9 @@ sub gettitle { unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } return &metadata($urlsymb,'title'); } - if ($titlecache{$symb}) { - if (time < ($titlecache{$symb}[1] + 600)) { - return $titlecache{$symb}[0]; - } else { - delete($titlecache{$symb}); - } - } - my ($map,$resid,$url)=split(/\_\_\_/,$symb); + my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',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', @@ -3724,8 +3899,7 @@ sub gettitle { } $title=~s/\&colon\;/\:/gs; if ($title) { - $titlecache{$symb}=[$title,time]; - return $title; + return &do_cache(\%titlecache,$symb,$title,'title'); } else { return &metadata($urlsymb,'title'); } @@ -3759,7 +3933,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); @@ -3802,6 +3976,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 { @@ -4101,10 +4292,26 @@ sub unescape { return $str; } +sub mod_perl_version { + if (defined($perlvar{'MODPERL2'})) { + return 2; + } + return 1; +} # ================================================================ Main Program sub goodbye { &logthis("Starting Shut down"); +#not converted to using infrastruture + &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); + &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); + &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); +#converted + &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); + &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); +#1.1 only + &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); + &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); &flushcourselogs(); &logthis("Shutting down"); return DONE; @@ -4148,11 +4355,16 @@ BEGIN { 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} ); }