--- loncom/lonnet/perl/lonnet.pm 2003/07/02 15:25:46 1.385
+++ loncom/lonnet/perl/lonnet.pm 2003/10/06 20:38:25 1.427
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.385 2003/07/02 15:25:46 matthew Exp $
+# $Id: lonnet.pm,v 1.427 2003/10/06 20:38:25 www 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;
}
@@ -556,9 +586,9 @@ sub authenticate {
sub homeserver {
my ($uname,$udom,$ignoreBadCache)=@_;
my $index="$uname:$udom";
- if ($homecache{$index}) {
- return "$homecache{$index}";
- }
+
+ my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
+ if (defined($cached)) { return $result; }
my $tryserver;
foreach $tryserver (keys %libserv) {
next if ($ignoreBadCache ne 'true' &&
@@ -566,8 +596,7 @@ sub homeserver {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {
- $homecache{$index}=$tryserver;
- return $tryserver;
+ return &do_cache(\%homecache,$index,$tryserver,'home');
} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;
}
@@ -819,8 +848,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 +956,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 +1335,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 +1403,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
+ '';
+ } else {
+ return '';
+ }
+ } else {
+ return '';
+ }
+}
+
# ---------------------------------------------------------- Course ID routines
# Deal with domain's nohist_courseid.db files
#
@@ -1425,19 +1591,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 '.
@@ -1936,14 +2102,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;
@@ -2077,6 +2243,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)=@_;
@@ -2096,27 +2277,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) {
@@ -2129,6 +2290,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 {
@@ -2209,6 +2397,9 @@ sub customaccess {
$access=($effect eq 'allow');
last;
}
+ if ($realm eq '' && $role eq '') {
+ $access=($effect eq 'allow');
+ }
}
return $access;
}
@@ -2221,6 +2412,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')) {
@@ -2512,8 +2704,36 @@ 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);
+ }
+}
+
+# --------------------------------------------------------- Get symb from alias
+
+sub get_symb_from_alias {
+ my $symb=shift;
+ my ($map,$resid,$url)=&decode_symb($symb);
+# Already is a symb
+ if ($url) { return $symb; }
+# Must be an alias
+ my $aliassymb='';
+ my %bighash;
+ if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
+ &GDBM_READER(),0640)) {
+ my $rid=$bighash{'mapalias_'.$symb};
+ if ($rid) {
+ my ($mapid,$resid)=split(/\./,$rid);
+ $aliassymb=
+ &declutter($bighash{'map_id_'.$mapid}).
+ '___'.$resid.'___'.
+ &declutter($bighash{'src_'.$rid});
+ }
+ untie %bighash;
}
+ return $aliassymb;
}
# ----------------------------------------------------------------- Define Role
@@ -2521,7 +2741,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\&/) {
@@ -2530,7 +2750,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\&/) {
@@ -2539,7 +2759,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\&/) {
@@ -2642,7 +2862,7 @@ sub userlog_query {
sub plaintext {
my $short=shift;
- return $prp{$short};
+ return &mt($prp{$short});
}
# ----------------------------------------------------------------- Assign Role
@@ -2651,7 +2871,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'});
@@ -2732,7 +2954,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.', '.
@@ -2744,7 +2966,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;
@@ -2774,7 +2997,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
@@ -2784,7 +3007,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));
@@ -2800,10 +3024,17 @@ sub modifyuser {
} else {
%names = @tmp;
}
- if (defined($first)) { $names{'firstname'} = $first; }
+#
+# Make sure to not trash student environment if instructor does not bother
+# to supply name and email information
+#
+ if ($first) { $names{'firstname'} = $first; }
if (defined($middle)) { $names{'middlename'} = $middle; }
- if (defined($last)) { $names{'lastname'} = $last; }
+ if ($last) { $names{'lastname'} = $last; }
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.', '.
@@ -2817,7 +3048,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';
@@ -2825,7 +3056,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
@@ -3060,7 +3291,7 @@ sub dirlist {
}
my $alldomstr='';
foreach (sort keys %alldom) {
- $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
+ $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';
}
$alldomstr=~s/:$//;
return split(/:/,$alldomstr);
@@ -3076,6 +3307,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;
@@ -3152,7 +3390,7 @@ sub condval {
sub devalidatecourseresdata {
my ($coursenum,$coursedomain)=@_;
my $hashid=$coursenum.':'.$coursedomain;
- delete $courseresdatacache{$hashid.'.time'};
+ &devalidate_cache(\%courseresdatacache,$hashid);
}
# --------------------------------------------------- Course Resourcedata Query
@@ -3161,25 +3399,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;
@@ -3196,7 +3432,7 @@ sub clear_EXT_cache_status {
sub EXT_cache_status {
my ($target_domain,$target_user) = @_;
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
- if (exists($ENV{$cachename}) && ($ENV{$cachename}+1800) > time) {
+ if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) {
# We know already the user has no data
return 1;
} else {
@@ -3212,12 +3448,15 @@ sub EXT_cache_set {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my ($varname,$symbparm,$udom,$uname,$usection)=@_;
+ my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
unless ($varname) { return ''; }
#get real user name/domain, courseid and symb
my $courseid;
my $publicuser;
+ if ($symbparm) {
+ $symbparm=&get_symb_from_alias($symbparm);
+ }
if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=
&Apache::lonxml::whichuser($symbparm);
@@ -3313,6 +3552,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;
@@ -3320,12 +3560,11 @@ 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'};
@@ -3347,19 +3586,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:".
@@ -3400,7 +3645,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'};
}
@@ -3416,9 +3661,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') {
@@ -3439,6 +3687,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;
@@ -3459,11 +3720,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;
@@ -3480,14 +3741,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'})) {
@@ -3507,6 +3769,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/^\_//;
@@ -3514,13 +3779,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;
}
@@ -3653,14 +3913,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',
@@ -3671,8 +3926,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');
}
@@ -3706,7 +3960,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);
@@ -3749,6 +4003,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 {
@@ -4048,10 +4319,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;
@@ -4092,13 +4379,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} );
}
@@ -4235,45 +4528,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
-no_such_host : unable to fund a host associated with the user/domain
+=over 4
+
+=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
@@ -4284,15 +4657,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
@@ -4301,50 +4677,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