--- loncom/lonnet/perl/lonnet.pm 2002/06/24 19:41:41 1.243 +++ loncom/lonnet/perl/lonnet.pm 2002/09/16 20:09:47 1.283 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.243 2002/06/24 19:41:41 albertel Exp $ +# $Id: lonnet.pm,v 1.283 2002/09/16 20:09:47 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -80,7 +80,7 @@ use vars qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom %libserv %pr %prp %metacache %packagetab %courselogs %accesshash $processmarker $dumpcount - %coursedombuf %coursehombuf %courseresdatacache); + %coursedombuf %coursehombuf %courseresdatacache %domaindescription); use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); @@ -348,6 +348,28 @@ sub delenv { return 'ok'; } +# ------------------------------------------ Fight off request when overloaded + +sub overloaderror { + my ($r,$checkserver)=@_; + unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } + my $loadavg; + if ($checkserver eq $perlvar{'lonHostID'}) { + my $loadfile=Apache::File->new('/proc/loadavg'); + $loadavg=<$loadfile>; + $loadavg =~ s/\s.*//g; + } else { + $loadavg=&reply('load',$checkserver); + } + my $overload=$loadavg-$perlvar{'lonLoadLim'}; + if ($overload>0) { + $r->err_headers_out->{'Retry-After'}=$overload*30; + $r->log_error('Overload of '.$overload.' on '.$checkserver); + return 413; + } + return ''; +} + # ------------------------------ Find server with least workload from spare.tab sub spareserver { @@ -608,6 +630,18 @@ sub userenvironment { return %returnhash; } +# -------------------------------------------------------------------- New chat + +sub chatsend { + my ($newentry,$anon)=@_; + my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + &reply('chatsend:'.$cdom.':'.$cnum.':'. + &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. + &escape($newentry)),$chome); +} + # ----------------------------- Subscribe to a resource, return URL if possible sub subscribe { @@ -708,6 +742,81 @@ sub ssi { return $response->content; } +# ------- Add a token to a remote URI's query string to vouch for access rights + +sub tokenwrapper { + my $uri=shift; + $uri=~s/^http\:\/\/([^\/]+)//; + $uri=~s/^\///; + $ENV{'user.environment'}=~/\/([^\/]+)\.id/; + my $token=$1; + if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { + &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); + return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. + (($uri=~/\?/)?'&':'?').'token='.$token; + } else { + return '/adm/notfound.html'; + } +} + +# --------------- Take an uploaded file and put it into the userfiles directory +# input: name of form element, coursedoc=1 means this is for the course +# output: url of file in userspace + +sub userfileupload { + my ($formname,$coursedoc)=@_; + my $fname=$ENV{'form.'.$formname.'.filename'}; + $fname=~s/\\/\//g; + $fname=~s/^.*\/([^\/]+)$/$1/; + unless ($fname) { return 'error: no uploaded file'; } + chop($ENV{'form.'.$formname}); +# Create the directory if not present + my $docuname=''; + my $docudom=''; + my $docuhome=''; + if ($coursedoc) { + $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + } else { + $docuname=$ENV{'user.name'}; + $docudom=$ENV{'user.domain'}; + $docuhome=$ENV{'user.home'}; + } + return + &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); +} + +sub finishuserfileupload { + my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; + my $path=$docudom.'/'.$docuname.'/'; + my $filepath=$perlvar{'lonDocRoot'}; + my @parts=split(/\//,$filepath.'/userfiles/'.$path); + my $count; + for ($count=4;$count<=$#parts;$count++) { + $filepath.="/$parts[$count]"; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } +# Save the file + { + my $fh=Apache::File->new('>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + } +# Notify homeserver to grep it +# + if +(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok') + { +# +# Return the URL to it + return '/uploaded/'.$path.$fname; + } else { + return '/adm/notfound.html'; + } +} + # ------------------------------------------------------------------------- Log sub log { @@ -739,7 +848,7 @@ sub flushcourselogs { my $entry=$_; $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; my %temphash=($entry => $accesshash{$entry}); - if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { + if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') { delete $accesshash{$entry}; } } @@ -784,7 +893,7 @@ sub countacc { my $url=&declutter(shift); unless ($ENV{'request.course.id'}) { return ''; } $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; - my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count'; + my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; if (defined($accesshash{$key})) { $accesshash{$key}++; } else { @@ -919,97 +1028,195 @@ sub devalidate { } } +sub get_scalar { + my ($string,$end) = @_; + my $value; + if ($$string =~ s/^([^&]*?)($end)/$2/) { + $value = $1; + } elsif ($$string =~ s/^([^&]*?)&//) { + $value = $1; + } + return &unescape($value); +} + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + sub arrayref2str { my ($arrayref) = @_; - my $result='_ARRAY_REF__'; + my $result='__ARRAY_REF__'; foreach my $elem (@$arrayref) { - if (ref($elem) eq 'ARRAY') { - $result.=&escape(&arrayref2str($elem)).'&'; - } elsif (ref($elem) eq 'HASH') { - $result.=&escape(&hashref2str($elem)).'&'; - } elsif (ref($elem)) { - &logthis("Got a ref of ".(ref($elem))." skipping."); + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); } else { $result.=&escape($elem).'&'; } } $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; return $result; } sub hash2str { my (%hash) = @_; my $result=&hashref2str(\%hash); - $result=~s/^_HASH_REF__//; + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; return $result; } sub hashref2str { my ($hashref)=@_; - my $result='_HASH_REF__'; + my $result='__HASH_REF__'; foreach (keys(%$hashref)) { if (ref($_) eq 'ARRAY') { - $result.=&escape(&arrayref2str($_)).'='; + $result.=&arrayref2str($_).'='; } elsif (ref($_) eq 'HASH') { - $result.=&escape(&hashref2str($_)).'='; + $result.=&hashref2str($_).'='; } elsif (ref($_)) { - &logthis("Got a ref of ".(ref($_))." skipping."); + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); } else { - $result.=&escape($_).'='; + if ($_) {$result.=&escape($_).'=';} else { last; } } - if (ref($$hashref{$_}) eq 'ARRAY') { - $result.=&escape(&arrayref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_}) eq 'HASH') { - $result.=&escape(&hashref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_})) { - &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); } else { - $result.=&escape($$hashref{$_}).'&'; + $result.=&escape($hashref->{$_}).'&'; } } $result=~s/\&$//; + $result .= '__END_HASH_REF__'; return $result; } sub str2hash { + my ($string)=@_; + my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); + return %$hash; +} + +sub str2hashref { my ($string) = @_; - my %returnhash; - foreach (split(/\&/,$string)) { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - $returnhash{$name}=$value; + + my %hash; + + if($string !~ /^__HASH_REF__/) { + if (! ($string eq '' || !defined($string))) { + $hash{'error'}='Not hash reference'; + } + return (\%hash, $string); + } + + $string =~ s/^__HASH_REF__//; + + while($string !~ /^__END_HASH_REF__/) { + #key + my $key=''; + if($string =~ /^__HASH_REF__/) { + ($key, $string)=&str2hashref($string); + if(defined($key->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($key, $string)=&str2arrayref($string); + if($key->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $string =~ s/^(.*?)=//; + $key=&unescape($1); + } + $string =~ s/^=//; + + #value + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $value=&get_scalar(\$string,'__END_HASH_REF__'); + } + $string =~ s/^&//; + + $hash{$key}=$value; } - return (%returnhash); + + $string =~ s/^__END_HASH_REF__//; + + return (\%hash, $string); } sub str2array { + my ($string)=@_; + my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); + return @$array; +} + +sub str2arrayref { my ($string) = @_; - my @returnarray; - foreach my $value (split(/\&/,$string)) { - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - push(@returnarray,$value); + my @array; + + if($string !~ /^__ARRAY_REF__/) { + if (! ($string eq '' || !defined($string))) { + $array[0]='Array reference error'; + } + return (\@array, $string); } - return (@returnarray); + + $string =~ s/^__ARRAY_REF__//; + + while($string !~ /^__END_ARRAY_REF__/) { + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } else { + $value=&get_scalar(\$string,'__END_ARRAY_REF__'); + } + $string =~ s/^&//; + + push(@array, $value); + } + + $string =~ s/^__END_ARRAY_REF__//; + + return (\@array, $string); } # -------------------------------------------------------------------Temp Store @@ -1033,7 +1240,7 @@ sub tmpreset { my %hash; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { foreach my $key (keys %hash) { if ($key=~ /:$symb/) { delete($hash{$key}); @@ -1069,7 +1276,7 @@ sub tmpstore { my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { $hash{"version:$symb"}++; my $version=$hash{"version:$symb"}; my $allkeys=''; @@ -1113,7 +1320,7 @@ sub tmprestore { my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { my $version=$hash{"version:$symb"}; $returnhash{'version'}=$version; my $scope; @@ -1256,7 +1463,7 @@ sub coursedescription { while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } - $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); + $returnhash{'url'}=&clutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.last_cache'}=time; @@ -1384,6 +1591,9 @@ sub get { my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } my %returnhash=(); my $i=0; foreach (@$storearr) { @@ -1516,6 +1726,17 @@ sub allowed { return ''; } } + if ($ENV{'request.role'}=~ /li\.\//) { + # Library role, so allow browsing of resources in this domain. + return 'F'; + } + } + # Domain coordinator is trying to create a course + if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { + # uri is the requested domain in this case. + # comparison to 'request.role.domain' shows if the user has selected + # a role of dc for the domain in question. + return 'F' if ($uri eq $ENV{'request.role.domain'}); } my $thisallowed=''; @@ -1737,9 +1958,15 @@ sub allowed { } } -# Restricted by state? +# Restricted by state or randomout? if ($thisallowed=~/X/) { + if ($ENV{'acc.randomout'}) { + my $symb=&symbread($uri,1); + if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { + return ''; + } + } if (&condval($statecond)) { return '2'; } else { @@ -1812,9 +2039,11 @@ sub definerole { # ---------------- Make a metadata query against the network of library servers sub metadata_query { - my ($query,$custom,$customshow)=@_; + my ($query,$custom,$customshow,$server_array)=@_; my %rhash; - for my $server (keys %libserv) { + my @server_list = (defined($server_array) ? @$server_array + : keys(%libserv) ); + for my $server (@server_list) { unless ($custom or $customshow) { my $reply=&reply("querysend:".&escape($query),$server); $rhash{$server}=$reply; @@ -1939,7 +2168,8 @@ sub modifyuserauth { my $uhome=&homeserver($uname,$udom); unless (&allowed('mau',$udom)) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. - $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, @@ -1970,7 +2200,8 @@ sub modifyuser { $last.', '.$gene.'(forceid: '.$forceid.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). - ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && ($umode) && ($upass)) { @@ -2095,13 +2326,10 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url)=@_; + my ($udom,$description,$url,$course_server,$nonstandard)=@_; $url=&declutter($url); my $cid=''; - unless (&allowed('ccc',$ENV{'user.domain'})) { - return 'refused'; - } - unless ($udom eq $ENV{'user.domain'}) { + unless (&allowed('ccc',$udom)) { return 'refused'; } # ------------------------------------------------------------------- Create ID @@ -2117,17 +2345,42 @@ sub createcourse { return 'error: unable to generate unique course-ID'; } } +# ------------------------------------------------ Check supplied server name + $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); + if (! exists($libserv{$course_server})) { + return 'error:bad server name '.$course_server; + } # ------------------------------------------------------------- Make the course my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', - $ENV{'user.home'}); + $course_server); unless ($reply eq 'ok') { return 'error: '.$reply; } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } +# ----------------------------------------------------------------- Course made + my $topurl=$url; + unless ($nonstandard) { +# ------------------------------------------ For standard courses, make top url + my $mapurl=&clutter($url); + if ($mapurl eq '/res/') { $mapurl=''; } + $ENV{'form.initmap'}=(< + + + + + + +ENDINITMAP + $topurl=&declutter( + &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + ); + } +# ----------------------------------------------------------- Write preferences &writecoursepref($udom.'_'.$uname, ('description' => $description, - 'url' => $url)); + 'url' => $topurl)); return '/'.$udom.'/'.$uname; } @@ -2158,51 +2411,98 @@ sub revokecustomrole { # ------------------------------------------------------------ Directory lister sub dirlist { - my $uri=shift; + my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; + $uri=~s/^\///; $uri=~s/\/$//; - my ($res,$udom,$uname,@rest)=split(/\//,$uri); - if ($udom) { - if ($uname) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri, - homeserver($uname,$udom)); - return split(/:/,$listing); - } else { - my $tryserver; - my %allusers=(); - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom, - $tryserver); - if (($listing ne 'no_such_dir') && ($listing ne 'empty') - && ($listing ne 'con_lost')) { - foreach (split(/:/,$listing)) { - my ($entry,@stat)=split(/&/,$_); - $allusers{$entry}=1; + my ($udom, $uname); + (undef,$udom,$uname)=split(/\//,$uri); + if(defined($userdomain)) { + $udom = $userdomain; + } + if(defined($username)) { + $uname = $username; + } + + my $dirRoot = $perlvar{'lonDocRoot'}; + if(defined($alternateDirectoryRoot)) { + $dirRoot = $alternateDirectoryRoot; + $dirRoot =~ s/\/$//; + } + + if($udom) { + if($uname) { + my $listing=reply('ls:'.$dirRoot.'/'.$uri, + homeserver($uname,$udom)); + return split(/:/,$listing); + } elsif(!defined($alternateDirectoryRoot)) { + my $tryserver; + my %allusers=(); + foreach $tryserver (keys %libserv) { + if($hostdom{$tryserver} eq $udom) { + my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + if (($listing ne 'no_such_dir') && ($listing ne 'empty') + && ($listing ne 'con_lost')) { + foreach (split(/:/,$listing)) { + my ($entry,@stat)=split(/&/,$_); + $allusers{$entry}=1; + } + } } - } - } - } - my $alluserstr=''; - foreach (sort keys %allusers) { - $alluserstr.=$_.'&user:'; - } - $alluserstr=~s/:$//; - return split(/:/,$alluserstr); - } - } else { - my $tryserver; - my %alldom=(); - foreach $tryserver (keys %libserv) { - $alldom{$hostdom{$tryserver}}=1; - } - my $alldomstr=''; - foreach (sort keys %alldom) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; - } - $alldomstr=~s/:$//; - return split(/:/,$alldomstr); - } + } + my $alluserstr=''; + foreach (sort keys %allusers) { + $alluserstr.=$_.'&user:'; + } + $alluserstr=~s/:$//; + return split(/:/,$alluserstr); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing user name'); + return split(':',@emptyResults); + } + } elsif(!defined($alternateDirectoryRoot)) { + my $tryserver; + my %alldom=(); + foreach $tryserver (keys %libserv) { + $alldom{$hostdom{$tryserver}}=1; + } + my $alldomstr=''; + foreach (sort keys %alldom) { + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; + } + $alldomstr=~s/:$//; + return split(/:/,$alldomstr); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing domain'); + return split(':',@emptyResults); + } +} + +# --------------------------------------------- GetFileTimestamp +# This function utilizes dirlist and returns the date stamp for +# when it was last modified. It will also return an error of -1 +# if an error occurs + +sub GetFileTimestamp { + my ($studentDomain,$studentName,$filename,$root)=@_; + $studentDomain=~s/\W//g; + $studentName=~s/\W//g; + my $subdir=$studentName.'__'; + $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 @stats = split('&', $fileStat); + if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + return $stats[9]; + } else { + return -1; + } } # -------------------------------------------------------- Value of a Condition @@ -2257,42 +2557,46 @@ sub condval { return $result; } +# ---------------------------------------------------- Devalidate courseresdata + +sub devalidatecourseresdata { + my ($coursenum,$coursedomain)=@_; + my $hashid=$coursenum.':'.$coursedomain; + delete $courseresdatacache{$hashid.'.time'}; +} + # --------------------------------------------------- Course Resourcedata Query sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - unless (defined($courseresdatacache{$hashid.'.time'})) { - unless (time-$courseresdatacache{$hashid.'.time'}<300) { - my $coursehom=&homeserver($coursenum,$coursedomain); - if ($coursehom) { - my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum. - ':resourcedata:.',$coursehom); - unless ($dumpreply=~/^error\:/) { - $courseresdatacache{$hashid.'.time'}=time; - $courseresdatacache{$hashid}=$dumpreply; - } - } - } + my $dodump=0; + if (!defined($courseresdatacache{$hashid.'.time'})) { + $dodump=1; + } else { + if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; } } - my @pairs=split(/\&/,$courseresdatacache{$hashid}); - my %returnhash=(); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_); - $returnhash{unescape($key)}=unescape($value); - } - my $item; - foreach $item (@which) { - if ($returnhash{$item}) { return $returnhash{$item}; } - } - return ''; + if ($dodump) { + my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + my ($tmp) = keys(%dumpreply); + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + $courseresdatacache{$hashid.'.time'}=time; + $courseresdatacache{$hashid}=\%dumpreply; + } + } + foreach my $item (@which) { + if ($courseresdatacache{$hashid}->{$item}) { + return $courseresdatacache{$hashid}->{$item}; + } + } + return ''; } # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname)=@_; + my ($varname,$symbparm,$udom,$uname,)=@_; unless ($varname) { return ''; } @@ -2391,7 +2695,7 @@ sub EXT { my $section; if (($ENV{'user.name'} eq $uname) && ($ENV{'user.domain'} eq $udom)) { - $section={'request.course.sec'}; + $section=$ENV{'request.course.sec'}; } else { $section=&usection($udom,$uname,$courseid); } @@ -2440,7 +2744,7 @@ sub EXT { my $thisparm=''; if (tie(%parmhash,'GDBM_File', $ENV{'request.course.fn'}.'_parms.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } @@ -2449,10 +2753,16 @@ sub EXT { # --------------------------------------------- last, look in resource metadata $spacequalifierrest=~s/\./\_/; - my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); + my $filename; + if (!$symbparm) { $symbparm=&symbread(); } + if ($symbparm) { + $filename=(split(/\_\_\_/,$symbparm))[2]; + } else { + $filename=$ENV{'request.filename'}; + } + my $metadata=&metadata($filename,$spacequalifierrest); if ($metadata) { return $metadata; } - $metadata=&metadata($ENV{'request.filename'}, - 'parameter_'.$spacequalifierrest); + $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); if ($metadata) { return $metadata; } # ------------------------------------------------------------------ Cascade up @@ -2501,7 +2811,7 @@ sub metadata { # Look at timestamp of caching # Everything is cached by the main uri, libraries are never directly cached # - unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { + unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) { # # Is this a recursive call for a library? # @@ -2524,7 +2834,7 @@ sub metadata { my $package=$token->[2]->{'package'}; my $keyroot=''; if ($prefix) { - $keyroot.='_'.$prefix; + $keyroot.=$prefix; } else { if (defined($token->[2]->{'part'})) { $keyroot.='_'.$token->[2]->{'part'}; @@ -2582,12 +2892,14 @@ sub metadata { # # Importing a library here # - if (defined($depthcount)) { $depthcount++; } else - { $depthcount=0; } if ($depthcount<20) { - foreach (split(/\,/,&metadata($uri,'keys', - $parser->get_text('/import'),$unikey, - $depthcount))) { + 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; } } @@ -2613,12 +2925,42 @@ sub metadata { } } $metacache{$uri.':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); + $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); $metacache{$uri.':cachedtimestamp'}=time; # this is the end of "was not already recently cached } return $metacache{$uri.':'.$what}; } +sub metadata_generate_part0 { + my ($metadata,$metacache,$uri) = @_; + my %allnames; + foreach my $metakey (sort keys %$metadata) { + if ($metakey=~/^parameter\_(.*)/) { + my $part=$$metacache{$uri.':'.$metakey.'.part'}; + my $name=$$metacache{$uri.':'.$metakey.'.name'}; + if (! exists($$metadata{'parameter_0_'.$name})) { + $allnames{$name}=$part; + } + } + } + foreach my $name (keys(%allnames)) { + $$metadata{"parameter_0_$name"}=1; + my $key="$uri:parameter_0_$name"; + $$metacache{"$key.part"}='0'; + $$metacache{"$key.name"}=$name; + $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'. + $allnames{$name}.'_'.$name. + '.type'}; + my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name. + '.display'}; + my $expr='\\[Part: '.$allnames{$name}.'\\]'; + $olddis=~s/$expr/\[Part: 0\]/; + $$metacache{"$key.display"}=$olddis; + } +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -2627,7 +2969,7 @@ sub symblist { my %hash; if (($ENV{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { foreach (keys %newhash) { $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; } @@ -2655,8 +2997,8 @@ sub symbverify { my %bighash; my $okay=0; if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', - &GDBM_READER,0640)) { - my $ids=$bighash{'ids_/res/'.$thisfn}; + &GDBM_READER(),0640)) { + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } @@ -2693,7 +3035,7 @@ sub symbclean { # ------------------------------------------------------ Return symb list entry sub symbread { - my $thisfn=shift; + my ($thisfn,$donotrecurse)=@_; # no filename provided? try from environment unless ($thisfn) { if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } @@ -2709,7 +3051,7 @@ sub symbread { my $syval=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { $syval=$hash{$thisfn}; untie(%hash); } @@ -2725,9 +3067,9 @@ sub symbread { } else { # ------------------------------------------------------- Was not in symb table if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { # ---------------------------------------------- Get ID(s) for current resource - my $ids=$bighash{'ids_/res/'.$thisfn}; + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } @@ -2742,7 +3084,7 @@ sub symbread { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; - } else { + } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; foreach (@possibilities) { @@ -2757,6 +3099,8 @@ sub symbread { } } if ($realpossible!=1) { $syval=''; } + } else { + $syval=''; } } untie(%bighash) @@ -2825,20 +3169,31 @@ sub ireceipt { } sub receipt { - return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, - $ENV{'request.course.id'},&symbread()); + my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + return &ireceipt($name,$domain,$courseid,$symb); } - + # ------------------------------------------------------------ Serves up a file # returns either the contents of the file or a -1 sub getfile { - my $file=shift; + my $file=shift; + if ($file=~/^\/*uploaded\//) { # user file + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $response=$ua->request($request); + if ($response->is_success()) { + return $response->content; + } else { + return -1; + } + } else { # normal file from res space &repcopy($file); if (! -e $file ) { return -1; }; my $fh=Apache::File->new($file); my $a=''; while (<$fh>) { $a .=$_; } - return $a + return $a; + } } sub filelocation { @@ -2848,6 +3203,8 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + $location=$file; } else { $file=~s/^$perlvar{'lonDocRoot'}//; $file=~s:^/*res::; @@ -2885,6 +3242,16 @@ sub declutter { return $thisfn; } +# ------------------------------------------------------------- Clutter up URLs + +sub clutter { + my $thisfn='/'.&declutter(shift); + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + $thisfn='/res'.$thisfn; + } + return $thisfn; +} + # -------------------------------------------------------- Escape Special Chars sub escape { @@ -2941,11 +3308,18 @@ BEGIN { while (my $configline=<$config>) { chomp($configline); - my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); - $hostname{$id}=$name; - $hostdom{$id}=$domain; - $hostip{$id}=$ip; - if ($role eq 'library') { $libserv{$id}=$name; } + my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); + if ($id && $domain && $role && $name && $ip) { + $hostname{$id}=$name; + $hostdom{$id}=$domain; + $hostip{$id}=$ip; + if ($domdescr) { $domaindescription{$domain}=$domdescr; } + if ($role eq 'library') { $libserv{$id}=$name; } + } else { + if ($configline) { + &logthis("Skipping hosts.tab line -$configline-"); + } + } } } @@ -3003,7 +3377,7 @@ BEGIN { %metacache=(); -$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; +$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; &logtouch();