--- loncom/lonnet/perl/lonnet.pm 2003/01/10 14:50:08 1.315 +++ loncom/lonnet/perl/lonnet.pm 2003/03/22 21:23:35 1.345 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.315 2003/01/10 14:50:08 www Exp $ +# $Id: lonnet.pm,v 1.345 2003/03/22 21:23:35 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -47,23 +47,18 @@ # 09/01 Guy Albertelli # 09/01,10/01,11/01 Gerd Kortemeyer # YEAR=2001 -# 02/27/01 Scott Harrison # 3/2 Gerd Kortemeyer -# 3/15,3/19 Scott Harrison # 3/19,3/20 Gerd Kortemeyer -# 3/22,3/27,4/2,4/16,4/17 Scott Harrison # 5/26,5/28 Gerd Kortemeyer # 5/30 H. K. Ng # 6/1 Gerd Kortemeyer # July Guy Albertelli # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, # 10/2 Gerd Kortemeyer -# 10/5,10/10,11/13,11/15 Scott Harrison # 11/17,11/20,11/22,11/29 Gerd Kortemeyer # 12/5 Matthew Hall # 12/5 Guy Albertelli # 12/6,12/7,12/12 Gerd Kortemeyer -# 12/18 Scott Harrison # 12/21,12/22,12/27,12/28 Gerd Kortemeyer # YEAR=2002 # 1/4,2/4,2/7 Gerd Kortemeyer @@ -81,7 +76,7 @@ qw(%perlvar %hostname %homecache %badSer %libserv %pr %prp %metacache %packagetab %titlecache %courselogs %accesshash $processmarker $dumpcount %coursedombuf %coursehombuf %courseresdatacache - %domaindescription); + %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); @@ -593,6 +588,92 @@ sub idput { } } +# --------------------------------------------------- Assign a key to a student + +sub assign_access_key { + my ($ckey,$cdom,$cnum,$udom,$uname)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$ENV{'user.name'} unless (defined($udom)); + $uname=$ENV{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + if (($existing{$ckey}=~/^\d+$/) || # has time - new key + ($existing{$ckey} eq $udom.':'.$uname)) { # this should not happen, + # unless something went wrong + # the first time around +# ready to assign + } elsif (!$existing{$ckey}) { + if (&put('accesskey',{$ckey=>$udom.':'.$uname},$cdom,$cnum) eq 'ok') { +# key now belongs to user + my $envkey='key.'.$cdom.'.'.$cnum; + if (&put('environment',{$envkey => $ckey}) eq 'ok') { + &appenv('environment.'.$envkey => $ckey); + return 'ok'; + } else { + return + 'error: Count not permanently assign key, will need to be re-entered later.'; + } + } else { + return 'error: Could not assign key, try again later.'; + } +# the key does not exist + return 'error: The key does not exist'; + } else { +# the key is somebody else's + return 'error: The key is already in use'; + } +} + +# ------------------------------------------------------ Generate a set of keys + +sub generate_access_keys { + my ($number,$cdom,$cnum)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + unless (&allowed('ccc',$cdom)) { return 0; } + unless (($cdom) && ($cnum)) { return 0; } + if ($number>10000) { return 0; } + sleep(2); # make sure don't get same seed twice + srand(time()^($$+($$<<15))); # from "Programming Perl" + my $total=0; + for (my $i=1;$i<=$number;$i++) { + my $newkey=sprintf("%lx",int(100000*rand)).'-'. + sprintf("%lx",int(100000*rand)).'-'. + sprintf("%lx",int(100000*rand)); + $newkey=~s/1/g/g; # folks mix up 1 and l + $newkey=~s/0/h/g; # and also 0 and O + my %existing=&get('accesskeys',[$newkey],$cdom,$cnum); + if ($existing{$newkey}) { + $i--; + } else { + if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') { + $total++; + } + } + } + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + 'Generated '.$total.' keys for '.$cnum.' at '.$cdom); + return $total; +} + +# ------------------------------------------------------- Validate an accesskey + +sub validate_access_key { + my ($ckey,$cdom,$cnum,$udom,$uname)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$ENV{'user.name'} unless (defined($udom)); + $uname=$ENV{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + return ($existing{$ckey} eq $udom.':'.$uname); +} + # ------------------------------------- Find the section of student in a course sub getsection { @@ -734,8 +815,8 @@ sub subscribe { $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); my $home=homeserver($uname,$udom); - if ($home eq 'no_host') { - return 'not_found'; + if ($home eq 'no_host') { + return 'not_found'; } my $answer=reply("sub:$fname",$home); if (($answer eq 'con_lost') || ($answer eq 'rejected')) { @@ -809,6 +890,18 @@ sub repcopy { } } +# ------------------------------------------------ Get server side include body +sub ssi_body { + my $filelink=shift; + my $output=($filelink=~/^http\:/?&externalssi($filelink): + &ssi($filelink)); + $output=~s/^.*\]*\>//si; + $output=~s/\<\/body\s*\>.*$//si; + $output=~ + s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; + return $output; +} + # --------------------------------------------------------- Server Side Include sub ssi { @@ -832,6 +925,14 @@ sub ssi { return $response->content; } +sub externalssi { + my ($url)=@_; + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',$url); + my $response=$ua->request($request); + return $response->content; +} + # ------- Add a token to a remote URI's query string to vouch for access rights sub tokenwrapper { @@ -864,7 +965,7 @@ sub userfileupload { # Replace spaces by underscores $fname=~s/\s+/\_/g; # Replace all other weird characters by nothing - $fname=~s/[^\w\.]//g; + $fname=~s/[^\w\.\-]//g; # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } chop($ENV{'form.'.$formname}); @@ -1109,10 +1210,14 @@ sub expirespread { # ----------------------------------------------------- Devalidate Spreadsheets sub devalidate { - my $symb=shift; + my ($symb,$uname,$udom)=@_; my $cid=$ENV{'request.course.id'}; if ($cid) { - my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; +# 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'], @@ -1123,7 +1228,7 @@ sub devalidate { [$key.'assesscalc:'.$symb]); unless ($status eq 'ok ok') { &logthis('Could not devalidate spreadsheet '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. + $uname.' at '.$udom.' for '. $symb.': '.$status); } } @@ -1455,7 +1560,10 @@ sub store { $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } - &devalidate($symb); + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + &devalidate($symb,$stuname,$domain); $symb=escape($symb); if (!$namespace) { @@ -1463,8 +1571,6 @@ sub store { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; foreach (keys %$storehash) { @@ -1486,7 +1592,10 @@ sub cstore { $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } - &devalidate($symb); + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + &devalidate($symb,$stuname,$domain); $symb=escape($symb); if (!$namespace) { @@ -1494,8 +1603,6 @@ sub cstore { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; @@ -1744,6 +1851,58 @@ sub dump { return %returnhash; } +# --------------------------------------------------------------- currentdump +sub currentdump { + my ($courseid,$sdom,$sname)=@_; + $courseid = $ENV{'request.course.id'} if (! defined($courseid)); + $sdom = $ENV{'user.domain'} if (! defined($sdom)); + $sname = $ENV{'user.name'} if (! defined($sname)); + my $uhome = &homeserver($sname,$sdom); + my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); + return if ($rep =~ /^(error:|no_such_host)/); + # + my %returnhash=(); + # + if ($rep eq "unknown_cmd") { + # an old lond will not know currentdump + # Do a dump and make it look like a currentdump + my @tmp = &dump($courseid,$sdom,$sname,'.'); + 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\./); + } + } + } else { + my @pairs=split(/\&/,$rep); + foreach (@pairs) { + my ($key,$value)=split(/=/,$_); + my ($symb,$param) = split(/:/,$key); + $returnhash{&unescape($symb)}->{&unescape($param)} = + &unescape($value); + } + } + return %returnhash; +} + # --------------------------------------------------------------- put interface sub put { @@ -1797,6 +1956,37 @@ sub eget { return %returnhash; } +# ---------------------------------------------- Custom access rule evaluation + +sub customaccess { + my ($priv,$uri)=@_; + my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); + $urealm=~s/^\W//; + my ($udom,$ucrs,$usec)=split(/\//,$urealm); + my $access=0; + foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { + my ($effect,$realm,$role)=split(/\:/,$_); + if ($role) { + if ($role ne $urole) { next; } + } + foreach (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$_); + if ($tdom) { + if ($tdom ne $udom) { next; } + } + if ($tcrs) { + if ($tcrs ne $ucrs) { next; } + } + if ($tsec) { + if ($tsec ne $usec) { next; } + } + $access=($effect eq 'allow'); + last; + } + } + return $access; +} + # ------------------------------------------------- Check for a user privilege sub allowed { @@ -1835,6 +2025,9 @@ sub allowed { # Library role, so allow browsing of resources in this domain. return 'F'; } + if ($copyright eq 'custom') { + unless (&customaccess($priv,$uri)) { return ''; } + } } # Domain coordinator is trying to create a course if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { @@ -2052,20 +2245,10 @@ sub allowed { if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; - my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; - if (-e $filename) { - my @content; - { - my $fh=Apache::File->new($filename); - @content=<$fh>; - } - if (join('',@content)=~ - /\]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + if (&metadata($uri,'roledeny')=~/$rolecode/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); - return ''; - - } + return ''; } } @@ -2096,6 +2279,7 @@ sub is_on_map { my $filename=$uriparts[$#uriparts]; my $pathname=$uri; $pathname=~s|/\Q$filename\E$||; + $pathname=~s/^adm\/wrapper\///; #Trying to find the conditional for the file my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ /\&\Q$filename\E\:([\d\|]+)\&/); @@ -2757,7 +2941,6 @@ sub EXT { my ($varname,$symbparm,$udom,$uname,)=@_; unless ($varname) { return ''; } - #get real user name/domain, courseid and symb my $courseid; if (!($uname && $udom)) { @@ -2766,14 +2949,14 @@ sub EXT { } else { $courseid=$ENV{'request.course.id'}; } - my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; - if ($therest[0]) { + if (defined($therest[0])) { $rest=join('.',@therest); } else { $rest=''; } + my $qualifierrest=$qualifier; if ($rest) { $qualifierrest.='.'.$rest; } my $spacequalifierrest=$space; @@ -2781,8 +2964,12 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - my %restored=&restore(undef,undef,$udom,$uname); - return $restored{$qualifierrest}; + if (defined($Apache::lonhomework::parsing_a_problem)) { + return $Apache::lonhomework::history{$qualifierrest}; + } else { + my %restored=&restore($symbparm,$courseid,$udom,$uname); + return $restored{$qualifierrest}; + } # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { # FIXME - not supporting calls for a specific user @@ -2817,9 +3004,8 @@ sub EXT { return $uname; # ---------------------------------------------------- Any other user namespace } else { - my $item=($rest)?$qualifier.'.'.$rest:$qualifier; - my %reply=&get($space,[$item]); - return $reply{$item}; + my %reply=&get($space,[$qualifierrest],$udom,$uname); + return $reply{$qualifierrest}; } } elsif ($realm eq 'query') { # ---------------------------------------------- pull stuff out of query string @@ -2936,16 +3122,13 @@ sub EXT { # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { - my ($part,$id)=split(/\_/,$space); - if ($id) { - my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm,$udom,$uname); - if (defined($partgeneral)) { return $partgeneral; } - } else { - my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, - $symbparm,$udom,$uname); - if (defined($resourcegeneral)) { return $resourcegeneral; } - } + my @parts=split(/_/,$space); + my $id=pop(@parts); + my $part=join('_',@parts); + if ($part eq '') { $part='0'; } + my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + $symbparm,$udom,$uname); + if (defined($partgeneral)) { return $partgeneral; } } # ---------------------------------------------------- Any other user namespace @@ -2967,6 +3150,22 @@ sub EXT { return ''; } +sub add_prefix_and_part { + my ($prefix,$part)=@_; + my $keyroot; + if (defined($prefix) && $prefix !~ /^__/) { + # prefix that has a part already + $keyroot=$prefix; + } elsif (defined($prefix)) { + # prefix that is missing a part + if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); } + } else { + # no prefix at all + if (defined($part)) { $keyroot='_'.$part; } + } + return $keyroot; +} + # ---------------------------------------------------------------- Get metadata sub metadata { @@ -2995,113 +3194,129 @@ sub metadata { } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } - my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); + my $metastring=&getfile(&filelocation('',&clutter($filename))); my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - if (defined($token->[2]->{'package'})) { + if ($token->[0] eq 'S') { + if (defined($token->[2]->{'package'})) { # # This is a package - get package info # - my $package=$token->[2]->{'package'}; - my $keyroot=''; - if ($prefix) { - $keyroot.=$prefix; - } else { - if (defined($token->[2]->{'part'})) { - $keyroot.='_'.$token->[2]->{'part'}; - } - } - if (defined($token->[2]->{'id'})) { - $keyroot.='_'.$token->[2]->{'id'}; - } - if ($metacache{$uri.':packages'}) { - $metacache{$uri.':packages'}.=','.$package.$keyroot; - } else { - $metacache{$uri.':packages'}=$package.$keyroot; - } - foreach (keys %packagetab) { - if ($_=~/^$package\&/) { - my ($pack,$name,$subp)=split(/\&/,$_); - my $value=$packagetab{$_}; - my $part=$keyroot; - $part=~s/^\_//; - if ($subp eq 'display') { - $value.=' [Part: '.$part.']'; - } - my $unikey='parameter'.$keyroot.'_'.$name; - $metathesekeys{$unikey}=1; - $metacache{$uri.':'.$unikey.'.part'}=$part; - unless - (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { - $metacache{$uri.':'.$unikey.'.'.$subp}=$value; - } - } - } - } else { + my $package=$token->[2]->{'package'}; + my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + if (defined($token->[2]->{'id'})) { + $keyroot.='_'.$token->[2]->{'id'}; + } + if ($metacache{$uri.':packages'}) { + $metacache{$uri.':packages'}.=','.$package.$keyroot; + } else { + $metacache{$uri.':packages'}=$package.$keyroot; + } + foreach (keys %packagetab) { + if ($_=~/^$package\&/) { + my ($pack,$name,$subp)=split(/\&/,$_); + my $value=$packagetab{$_}; + my $part=$keyroot; + $part=~s/^\_//; + if ($subp eq 'display') { + $value.=' [Part: '.$part.']'; + } + my $unikey='parameter'.$keyroot.'_'.$name; + if ($subp eq 'default') { $unikey='parameter_0_'.$name; } + $metathesekeys{$unikey}=1; + $metacache{$uri.':'.$unikey.'.part'}=$part; + unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { + $metacache{$uri.':'.$unikey.'.'.$subp}=$value; + } + if (defined($metacache{$uri.':'.$unikey.'.default'})) { + $metacache{$uri.':'.$unikey}= + $metacache{$uri.':'.$unikey.'.default'} + } + } + } + } else { # # This is not a package - some other kind of start tag -# - my $entry=$token->[1]; - my $unikey; - if ($entry eq 'import') { - $unikey=''; - } else { - $unikey=$entry; - } - if ($prefix) { - $unikey.=$prefix; - } else { - if (defined($token->[2]->{'part'})) { - $unikey.='_'.$token->[2]->{'part'}; - } - } - if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; - } +# + my $entry=$token->[1]; + my $unikey; + if ($entry eq 'import') { + $unikey=''; + } else { + $unikey=$entry; + } + $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); - if ($entry eq 'import') { + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } + + if ($entry eq 'import') { # # Importing a library here -# - if ($depthcount<20) { - my $location=$parser->get_text('/import'); - my $dir=$filename; - $dir=~s|[^/]*$||; - $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,$unikey, - $depthcount+1)))) { - $metathesekeys{$_}=1; - } - } - } else { - - if (defined($token->[2]->{'name'})) { - $unikey.='_'.$token->[2]->{'name'}; - } - $metathesekeys{$unikey}=1; - foreach (@{$token->[3]}) { - $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; - } - unless ( - $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) - ) { $metacache{$uri.':'.$unikey}= - $metacache{$uri.':'.$unikey.'.default'}; - } +# + if ($depthcount<20) { + my $location=$parser->get_text('/import'); + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,$unikey, + $depthcount+1)))) { + $metathesekeys{$_}=1; + } + } + } else { + + if (defined($token->[2]->{'name'})) { + $unikey.='_'.$token->[2]->{'name'}; + } + $metathesekeys{$unikey}=1; + foreach (@{$token->[3]}) { + $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; + } + my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); + my $default=$metacache{$uri.':'.$unikey.'.default'}; + if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { + # only ws inside the tag, and not in default, so use default + # as value + $metacache{$uri.':'.$unikey}=$default; + } else { + # either something interesting inside the tag or default + # uninteresting + $metacache{$uri.':'.$unikey}=$internaltext; + } # end of not-a-package not-a-library import - } + } # end of not-a-package start tag - } + } # the next is the end of "start tag" - } - } - $metacache{$uri.':keys'}=join(',',keys %metathesekeys); + } + } +# are there custom rights to evaluate + if ($metacache{$uri.':copyright'} eq 'custom') { + + # + # Importing a rights file here + # + unless ($depthcount) { + my $location=$metacache{$uri.':customdistributionfile'}; + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,'_rights', + $depthcount+1)))) { + $metathesekeys{$_}=1; + } + } + } + $metacache{$uri.':keys'}=join(',',keys %metathesekeys); &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); - $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); - $metacache{$uri.':cachedtimestamp'}=time; + $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); + $metacache{$uri.':cachedtimestamp'}=time; # this is the end of "was not already recently cached } return $metacache{$uri.':'.$what}; @@ -3503,6 +3718,29 @@ BEGIN { } } +# ------------------------------------------------------------ Read domain file +{ + my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. + '/domain.tab'); + %domaindescription = (); + %domain_auth_def = (); + %domain_auth_arg_def = (); + if ($fh) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($domain, $domain_description, $def_auth, $def_auth_arg) + = split(/:/,$_,4); + $domain_auth_def{$domain}=$def_auth; + $domain_auth_arg_def{$domain}=$def_auth_arg; + $domaindescription{$domain}=$domain_description; +# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); +# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); + } + } +} + + # ------------------------------------------------------------- Read hosts file { my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); @@ -3516,7 +3754,6 @@ BEGIN { $hostdom{$id}=$domain; $hostip{$id}=$ip; $iphost{$ip}=$id; - if ($domdescr) { $domaindescription{$domain}=$domdescr; } if ($role eq 'library') { $libserv{$id}=$name; } } else { if ($configline) { @@ -3578,6 +3815,12 @@ BEGIN { } } +# ------------- set up temporary directory +{ + $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; + +} + %metacache=(); $processmarker='_'.time.'_'.$perlvar{'lonHostID'};