--- loncom/lonnet/perl/lonnet.pm 2003/01/28 00:09:57 1.320 +++ loncom/lonnet/perl/lonnet.pm 2003/03/07 23:37:09 1.335 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.320 2003/01/28 00:09:57 albertel Exp $ +# $Id: lonnet.pm,v 1.335 2003/03/07 23:37:09 albertel 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); @@ -734,8 +729,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 +804,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 +839,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 { @@ -1109,10 +1124,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 +1142,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 +1474,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 +1485,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 +1506,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 +1517,6 @@ sub cstore { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; @@ -1746,11 +1767,12 @@ sub dump { # --------------------------------------------------------------- currentdump sub currentdump { - my ($namespace,$udomain,$uname)=@_; - if (!$udomain) { $udomain = $ENV{'user.domain'}; } - if (!$uname) { $uname = $ENV{'user.name'}; } - my $uhome = &homeserver($uname,$udomain); - my $rep=reply("currentdump:$udomain:$uname:$namespace",$uhome); + 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=(); @@ -1758,7 +1780,7 @@ sub currentdump { 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($namespace,$udomain,$uname,'.'); + my @tmp = &dump($courseid,$sdom,$sname,'.'); return if ($tmp[0] =~ /^(error:|no_such_host)/); my %hash = @tmp; @tmp=(); @@ -2147,6 +2169,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\|]+)\&/); @@ -2832,8 +2855,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 @@ -2868,9 +2895,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 @@ -2987,7 +3013,7 @@ sub EXT { # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { - my ($part,$id)=split(/\_/,$space); + my ($part,$id)=split(/_/,$space); if ($id) { my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, $symbparm,$udom,$uname); @@ -3018,6 +3044,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 { @@ -3046,7 +3088,7 @@ 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; @@ -3057,14 +3099,7 @@ sub metadata { # 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'}; - } - } + my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'}); if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } @@ -3085,9 +3120,12 @@ sub metadata { my $unikey='parameter'.$keyroot.'_'.$name; $metathesekeys{$unikey}=1; $metacache{$uri.':'.$unikey.'.part'}=$part; - unless - (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { - $metacache{$uri.':'.$unikey.'.'.$subp}=$value; + unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { + $metacache{$uri.':'.$unikey.'.'.$subp}=$value; + } + if (defined($metacache{$uri.':'.$unikey.'.default'})) { + $metacache{$uri.':'.$unikey}= + $metacache{$uri.':'.$unikey.'.default'} } } } @@ -3102,13 +3140,8 @@ sub metadata { } else { $unikey=$entry; } - if ($prefix) { - $unikey.=$prefix; - } else { - if (defined($token->[2]->{'part'})) { - $unikey.='_'.$token->[2]->{'part'}; - } - } + $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + if (defined($token->[2]->{'id'})) { $unikey.='_'.$token->[2]->{'id'}; } @@ -3137,11 +3170,17 @@ sub metadata { 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'}; - } + 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 @@ -3554,6 +3593,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"); @@ -3567,7 +3629,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) { @@ -3629,6 +3690,12 @@ BEGIN { } } +# ------------- set up temporary directory +{ + $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; + +} + %metacache=(); $processmarker='_'.time.'_'.$perlvar{'lonHostID'};