--- loncom/lonnet/perl/lonnet.pm 2004/07/06 18:02:33 1.521 +++ loncom/lonnet/perl/lonnet.pm 2004/10/26 17:20:09 1.554 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.521 2004/07/06 18:02:33 raeburn Exp $ +# $Id: lonnet.pm,v 1.554 2004/10/26 17:20:09 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -39,7 +39,7 @@ qw(%perlvar %hostname %homecache %badSer %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache - %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def + %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); use IO::Socket; @@ -50,8 +50,9 @@ use Fcntl qw(:flock); use Apache::loncoursedata; use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); -use Time::HiRes(); +use Time::HiRes qw( gettimeofday tv_interval ); my $readit; +my $max_connection_retries = 10; # Or some such value. =pod @@ -116,14 +117,40 @@ sub logperm { sub subreply { my ($cmd,$server)=@_; my $peerfile="$perlvar{'lonSockDir'}/$server"; - my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", - Type => SOCK_STREAM, - Timeout => 10) - or return "con_lost"; - print $client "$cmd\n"; - my $answer=<$client>; - if (!$answer) { $answer="con_lost"; } - chomp($answer); + # + # With loncnew process trimming, there's a timing hole between lonc server + # process exit and the master server picking up the listen on the AF_UNIX + # socket. In that time interval, a lock file will exist: + + my $lockfile=$peerfile.".lock"; + while (-e $lockfile) { # Need to wait for the lockfile to disappear. + sleep(1); + } + # At this point, either a loncnew parent is listening or an old lonc + # or loncnew child is listening so we can connect or everything's dead. + # + # We'll give the connection a few tries before abandoning it. If + # connection is not possible, we'll con_lost back to the client. + # + my $client; + for (my $retries = 0; $retries < $max_connection_retries; $retries++) { + $client=IO::Socket::UNIX->new(Peer =>"$peerfile", + Type => SOCK_STREAM, + Timeout => 10); + if($client) { + last; # Connected! + } + sleep(1); # Try again later if failed connection. + } + my $answer; + if ($client) { + print $client "$cmd\n"; + $answer=<$client>; + if (!$answer) { $answer="con_lost"; } + chomp($answer); + } else { + $answer = 'con_lost'; # Failed connection. + } return $answer; } @@ -434,7 +461,7 @@ sub overloaderror { if ($overload>0) { $r->err_headers_out->{'Retry-After'}=$overload; $r->log_error('Overload of '.$overload.' on '.$checkserver); - return 409; + return 413; } return ''; } @@ -771,6 +798,11 @@ sub getsection { my ($udom,$unam,$courseid)=@_; $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; + + my $hashid="$udom:$unam:$courseid"; + my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection'); + if (defined($cached)) { return $result; } + my %Pending; my %Expired; # @@ -795,29 +827,29 @@ sub getsection { if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); my $now=time; - if (defined($end) && ($now > $end)) { + if (defined($end) && $end && ($now > $end)) { $Expired{$end}=$section; next; } - if (defined($start) && ($now < $start)) { + if (defined($start) && $start && ($now < $start)) { $Pending{$start}=$section; next; } - return $section; + return &do_cache(\%getsectioncache,$hashid,$section,'getsection'); } # # Presumedly there will be few matching roles from the above # loop and the sorting time will be negligible. if (scalar(keys(%Pending))) { my ($time) = sort {$a <=> $b} keys(%Pending); - return $Pending{$time}; + return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection'); } if (scalar(keys(%Expired))) { my @sorted = sort {$a <=> $b} keys(%Expired); my $time = pop(@sorted); - return $Expired{$time}; + return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection'); } - return '-1'; + return &do_cache(\%getsectioncache,$hashid,'-1','getsection'); } @@ -826,10 +858,12 @@ my $disk_caching_disabled=1; sub devalidate_cache { my ($cache,$id,$name) = @_; delete $$cache{$id.'.time'}; + delete $$cache{$id.'.file'}; delete $$cache{$id}; - if ($disk_caching_disabled) { return; } + if (1 || $disk_caching_disabled) { return; } my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); + if (!-e $filename) { return; } + open(DB,">$filename.lock"); flock(DB,LOCK_EX); my %hash; if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { @@ -856,16 +890,32 @@ sub is_cached { my ($cache,$id,$name,$time) = @_; if (!$time) { $time=300; } if (!exists($$cache{$id.'.time'})) { - &load_cache_item($cache,$name,$id); + &load_cache_item($cache,$name,$id,$time); } if (!exists($$cache{$id.'.time'})) { # &logthis("Didn't find $id"); return (undef,undef); } else { if (time-($$cache{$id.'.time'})>$time) { -# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); - &devalidate_cache($cache,$id,$name); - return (undef,undef); + if (exists($$cache{$id.'.file'})) { + foreach my $filename (@{ $$cache{$id.'.file'} }) { + my $mtime=(stat($filename))[9]; + #+1 is to take care of edge effects + if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) { +# &logthis("Upping $mtime - ".$$cache{$id.'.time'}. +# "$id because of $filename"); + } else { + &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'}))); + &devalidate_cache($cache,$id,$name); + return (undef,undef); + } + } + $$cache{$id.'.time'}=time; + } else { +# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); + &devalidate_cache($cache,$id,$name); + return (undef,undef); + } } } return ($$cache{$id},1); @@ -881,44 +931,69 @@ sub do_cache { $$cache{$id}; } +my %do_save_item; +my %do_save; sub save_cache_item { my ($cache,$name,$id)=@_; if ($disk_caching_disabled) { return; } - my $starttime=&Time::HiRes::time(); -# &logthis("Saving :$name:$id"); - my %hash; - my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); - flock(DB,LOCK_EX); - if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { - eval <<'EVALBLOCK'; - $hash{$id.'.time'}=$$cache{$id.'.time'}; - $hash{$id}=freeze({'item'=>$$cache{$id}}); + $do_save{$name}=$cache; + if (!exists($do_save_item{$name})) { $do_save_item{$name}={} } + $do_save_item{$name}->{$id}=1; + return; +} + +sub save_cache { + if ($disk_caching_disabled) { return; } + my ($cache,$name,$id); + foreach $name (keys(%do_save)) { + $cache=$do_save{$name}; + + my $starttime=&Time::HiRes::time(); + &logthis("Saving :$name:"); + my %hash; + my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; + open(DB,">$filename.lock"); + flock(DB,LOCK_EX); + if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { + foreach $id (keys(%{ $do_save_item{$name} })) { + eval <<'EVALBLOCK'; + $hash{$id.'.time'}=$$cache{$id.'.time'}; + $hash{$id}=freeze({'item'=>$$cache{$id}}); + if (exists($$cache{$id.'.file'})) { + $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}}); + } EVALBLOCK - if ($@) { - &logthis("save_cache blew up :$@:$name"); - unlink($filename); - } - } else { - if (-e $filename) { - &logthis("Unable to tie hash (save cache item): $name ($!)"); - unlink($filename); + if ($@) { + &logthis("save_cache blew up :$@:$name"); + unlink($filename); + last; + } + } + } else { + if (-e $filename) { + &logthis("Unable to tie hash (save cache): $name ($!)"); + unlink($filename); + } } + untie(%hash); + flock(DB,LOCK_UN); + close(DB); + &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime)); } - untie(%hash); - flock(DB,LOCK_UN); - close(DB); -# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime)); + undef(%do_save); + undef(%do_save_item); + } sub load_cache_item { - my ($cache,$name,$id)=@_; + my ($cache,$name,$id,$time)=@_; if ($disk_caching_disabled) { return; } my $starttime=&Time::HiRes::time(); # &logthis("Before Loading $name for $id size is ".scalar(%$cache)); my %hash; my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); + if (!-e $filename) { return; } + open(DB,">$filename.lock"); flock(DB,LOCK_SH); if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { eval <<'EVALBLOCK'; @@ -935,9 +1010,17 @@ sub load_cache_item { } # &logthis("Initial load: $count"); } else { - my $hashref=thaw($hash{$id}); - $$cache{$id}=$hashref->{'item'}; - $$cache{$id.'.time'}=$hash{$id.'.time'}; + if (($$cache{$id.'.time'}+$time) < time) { + $$cache{$id.'.time'}=$hash{$id.'.time'}; + { + my $hashref=thaw($hash{$id}); + $$cache{$id}=$hashref->{'item'}; + } + if (exists($hash{$id.'.file'})) { + my $hashref=thaw($hash{$id.'.file'}); + $$cache{$id.'.file'}=$hashref->{'item'}; + } + } } EVALBLOCK if ($@) { @@ -957,38 +1040,6 @@ EVALBLOCK # &logthis("load_cache_item $name 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', - &homeserver($unam,$udom)))) { - my ($key,$value)=split(/\=/,$_); - $key=&unescape($key); - if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) { - my $section=$1; - if ($key eq $courseid.'_st') { $section=''; } - my ($dummy,$end,$start)=split(/\_/,&unescape($value)); - my $now=time; - my $notactive=0; - if ($start) { - if ($now<$start) { $notactive=1; } - } - if ($end) { - if ($now>$end) { $notactive=1; } - } - unless ($notactive) { - return &do_cache(\%usectioncache,$hashid,$section,'usection'); - } - } - } - return &do_cache(\%usectioncache,$hashid,'-1','usection'); -} - # ------------------------------------- Read an entry from a user's environment sub userenvironment { @@ -1047,6 +1098,7 @@ sub currentversion { sub subscribe { my $fname=shift; if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } + $fname=~s/[\n\r]//g; my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); @@ -1066,7 +1118,13 @@ sub subscribe { sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; - if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } + if ($filename=~m|^/home/httpd/html/adm/|) { return OK; } + if ($filename=~m|^/home/httpd/html/lonUsers/|) { return OK; } + if ($filename=~m|^/home/httpd/html/userfiles/| or + $filename=~m|^/*uploaded/|) { + return &repcopy_userfile($filename); + } + $filename=~s/[\n\r]//g; my $transname="$filename.in.transfer"; if ((-e $filename) || (-e $transname)) { return OK; } my $remoteurl=subscribe($filename); @@ -1131,10 +1189,10 @@ sub ssi_body { my ($filelink,%form)=@_; my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); - $output=~s/^.*?\]*\>//si; - $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; $output=~ s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; + $output=~s/^.*?\]*\>//si; + $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; return $output; } @@ -1267,10 +1325,8 @@ sub process_coursefile { # input: name of form element, coursedoc=1 means this is for the course # output: url of file in userspace -sub userfileupload { - my ($formname,$coursedoc,$subdir)=@_; - if (!defined($subdir)) { $subdir='unknown'; } - my $fname=$ENV{'form.'.$formname.'.filename'}; +sub clean_filename { + my ($fname)=@_; # Replace Windows backslashes by forward slashes $fname=~s/\\/\//g; # Get rid of everything but the actual filename @@ -1279,9 +1335,36 @@ sub userfileupload { $fname=~s/\s+/\_/g; # Replace all other weird characters by nothing $fname=~s/[^\w\.\-]//g; +# Replace all .\d. sequences with _\d. so they no longer look like version +# numbers + $fname=~s/\.(\d+)(?=\.)/_$1/g; + return $fname; +} + +sub userfileupload { + my ($formname,$coursedoc,$subdir)=@_; + if (!defined($subdir)) { $subdir='unknown'; } + my $fname=$ENV{'form.'.$formname.'.filename'}; + $fname=&clean_filename($fname); # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } chop($ENV{'form.'.$formname}); + if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently + my $now = time; + my $filepath = 'tmp/helprequests/'.$now; + my @parts=split(/\//,$filepath); + my $fullpath = $perlvar{'lonDaemons'}; + for (my $i=0;$i<@parts;$i++) { + $fullpath .= '/'.$parts[$i]; + if ((-e $fullpath)!=1) { + mkdir($fullpath,0777); + } + } + open(my $fh,'>'.$fullpath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + close($fh); + return $fullpath.'/'.$fname; + } # Create the directory if not present my $docuname=''; my $docudom=''; @@ -1356,6 +1439,19 @@ sub removeuserfile { return &reply("removeuserfile:$docudom/$docuname/$fname",$home); } +sub mkdiruserfile { + my ($docuname,$docudom,$dir)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home); +} + +sub renameuserfile { + my ($docuname,$docudom,$old,$new)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. + &escape("$new"),$home); +} + # ------------------------------------------------------------------------- Log sub log { @@ -1777,6 +1873,7 @@ sub devalidate { # - 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 + # - current conditional state info my $key=$uname.':'.$udom.':'; my $status= &del('nohist_calculatedsheets', @@ -1791,6 +1888,7 @@ sub devalidate { $uname.' at '.$udom.' for '. $symb.': '.$status); } + &delenv('user.state.'.$cid); } } @@ -2575,6 +2673,30 @@ sub put { return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } +# ---------------------------------------------------------- putstore interface + +sub putstore { + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + my %allitems = (); + foreach (keys %$storehash) { + if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { + my $key = $1.':keys:'.$2; + $allitems{$key} .= $3.':'; + } + $items.=$_.'='.&escape($$storehash{$_}).'&'; + } + foreach (keys %allitems) { + $allitems{$_} =~ s/\:$//; + $items.= $_.'='.$allitems{$_}.'&'; + } + $items=~s/\&$//; + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); +} + # ------------------------------------------------------ critical put interface sub cput { @@ -2654,14 +2776,23 @@ sub allowed { $uri=&deversion($uri); 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')) { + if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) + || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { return 'F'; } +# Free bre access to user's own portfolio contents + my ($space,$domain,$name,$dir)=split('/',$uri); + if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && + ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { + return 'F'; + } + # Free bre to public access if ($priv eq 'bre') { @@ -2927,6 +3058,9 @@ sub allowed { return ''; } } + if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) { + &Apache::lonuserstate::evalstate(); + } if (&condval($statecond)) { return '2'; } else { @@ -3063,8 +3197,10 @@ sub log_query { sub fetch_enrollment_query { my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; my $homeserver; + my $maxtries = 1; if ($context eq 'automated') { $homeserver = $perlvar{'lonHostID'}; + $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout } else { $homeserver = &homeserver($cnum,$dom); } @@ -3077,9 +3213,19 @@ sub fetch_enrollment_query { $cmd = &escape($cmd); my $query = 'fetchenrollment'; my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); - unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; } + unless ($queryid=~/^\Q$host\E\_/) { + &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); + return 'error: '.$queryid; + } my $reply = &get_query_reply($queryid); - unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + my $tries = 1; + while (($reply=~/^timeout/) && ($tries < $maxtries)) { + $reply = &get_query_reply($queryid); + $tries ++; + } + if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); + } else { my @responses = split/:/,$reply; if ($homeserver eq $perlvar{'lonHostID'}) { foreach (@responses) { @@ -3096,10 +3242,14 @@ sub fetch_enrollment_query { my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; my $destname = $pathname.'/'.$filename; my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); - unless ($xml_classlist =~ /^error/) { + if ($xml_classlist =~ /^error/) { + &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); + } else { if ( open(FILE,">$destname") ) { print FILE &unescape($xml_classlist); close(FILE); + } else { + &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); } } } @@ -3609,38 +3759,11 @@ sub revokecustomrole { $deleteflag); } - -# ------------------------------------------------------------ Portfolio Director Lister -# returns listing of contents of user's /userfiles/portfolio/ directory -# - -sub portfoliolist { - my ($currentPath, $currentFile) = @_; - my ($udom, $uname, $portfolioRoot); - $uname=$ENV{'user.name'}; - $udom=$ENV{'user.domain'}; - # really should interrogate the system for home directory information, but . . . - $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/'; - $uname =~ /^(.?)(.?)(.?)/; - $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio'; - my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom)); - return $listing; -} - -sub portfoliomanage { - -#FIXME please user the existing remove userfile function instead and -#add a userfilerename functions. -#FIXME uhome should never be an argument to any lonnet functions - - # handles deleting and renaming files in user's userfiles/portfolio/ directory - # - my ($filename, $fileaction, $filenewname) = @_; - my ($udom, $uname, $uhome); - $uname=$ENV{'user.name'}; - $udom=$ENV{'user.domain'}; - $uhome=$ENV{'user.home'}; - my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome); +# ------------------------------------------------------------ Disk usage +sub diskusage { + my ($udom,$uname,$directoryRoot)=@_; + $directoryRoot =~ s/\/$//; + my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); return $listing; } @@ -3978,11 +4101,14 @@ sub EXT { my $section; if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { + if (!$symbparm) { $symbparm=&symbread(); } + } + if ($symbparm && defined($courseid) && + $courseid eq $ENV{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme - if (!$symbparm) { $symbparm=&symbread(); } my $symbp=$symbparm; my $mapp=(&decode_symb($symbp))[0]; @@ -3993,11 +4119,11 @@ sub EXT { ($ENV{'user.domain'} eq $udom)) { $section=$ENV{'request.course.sec'}; } else { - if (! defined($usection)) { - $section=&usection($udom,$uname,$courseid); - } else { - $section = $usection; - } + if (! defined($usection)) { + $section=&getsection($udom,$uname,$courseid); + } else { + $section = $usection; + } } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -4035,7 +4161,7 @@ sub EXT { $uname." at ".$udom.": ". $tmp.""); } elsif ($tmp=~/error: 2 /) { - &EXT_cache_set($udom,$uname); + &EXT_cache_set($udom,$uname); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } @@ -4045,10 +4171,10 @@ sub EXT { # -------------------------------------------------------- second, check course my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, - $ENV{'course.'.$courseid.'.domain'}, - ($seclevelr,$seclevelm,$seclevel, - $courselevelr,$courselevelm, - $courselevel)); + $ENV{'course.'.$courseid.'.domain'}, + ($seclevelr,$seclevelm,$seclevel, + $courselevelr,$courselevelm, + $courselevel)); if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms @@ -4148,7 +4274,9 @@ 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|)) || + if (($uri eq '') || + (($uri =~ m|^/*adm/|) && + ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || ($uri =~ m|home/[^/]+/public_html/|)) { return undef; @@ -4181,7 +4309,9 @@ sub metadata { unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; if ($uri !~ m|^uploaded/|) { - $metastring=&getfile(&filelocation('',&clutter($filename))); + my $file=&filelocation('',&clutter($filename)); + push(@{$metacache{$uri.'.file'}},$file); + $metastring=&getfile($file); } my $parser=HTML::LCParser->new(\$metastring); my $token; @@ -4394,27 +4524,27 @@ sub metadata_generate_part0 { sub gettitle { my $urlsymb=shift; my $symb=&symbread($urlsymb); - unless ($symb) { - unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } - return &metadata($urlsymb,'title'); - } - 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', - &GDBM_READER(),0640)) { - my $mapid=$bighash{'map_pc_'.&clutter($map)}; - $title=$bighash{'title_'.$mapid.'.'.$resid}; - untie %bighash; - } - $title=~s/\&colon\;/\:/gs; - if ($title) { - return &do_cache(\%titlecache,$symb,$title,'title'); - } else { - return &metadata($urlsymb,'title'); - } + if ($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', + &GDBM_READER(),0640)) { + my $mapid=$bighash{'map_pc_'.&clutter($map)}; + $title=$bighash{'title_'.$mapid.'.'.$resid}; + untie %bighash; + } + $title=~s/\&colon\;/\:/gs; + if ($title) { + return &do_cache(\%titlecache,$symb,$title,'title'); + } + $urlsymb=$url; + } + my $title=&metadata($urlsymb,'title'); + if (!$title) { $title=(split('/',$urlsymb))[-1]; } + return $title; } # ------------------------------------------------- Update symbolic store links @@ -4546,14 +4676,20 @@ sub deversion { sub symbread { my ($thisfn,$donotrecurse)=@_; + my $cache_str='request.symbread.cached.'.$thisfn; + if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; } # no filename provided? try from environment unless ($thisfn) { - if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } + if ($ENV{'request.symb'}) { + return $ENV{$cache_str}=&symbclean($ENV{'request.symb'}); + } $thisfn=$ENV{'request.filename'}; } # is that filename actually a symb? Verify, clean, and return if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { - if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } + if (&symbverify($thisfn,$1)) { + return $ENV{$cache_str}=&symbclean($thisfn); + } } $thisfn=declutter($thisfn); my %hash; @@ -4574,7 +4710,7 @@ sub symbread { unless ($syval=~/\_\d+$/) { unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { &appenv('request.ambiguous' => $thisfn); - return ''; + return $ENV{$cache_str}=''; } $syval.=$1; } @@ -4621,11 +4757,11 @@ sub symbread { } } if ($syval) { - return &symbclean($syval.'___'.$thisfn); + return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); - return ''; + return $ENV{$cache_str}=''; } # ---------------------------------------------------------- Return random seed @@ -4886,30 +5022,32 @@ sub receipt { # the local server. sub getfile { - my ($file,$caller) = @_; + my ($file) = @_; - if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { - # normal file from res space - &repcopy($file); - return &readfile($file); - } - - my $info; - my $cdom = $1; - my $cnum = $2; - my $filename = $3; - my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles'; - my ($lwpresp,$rtncode); - my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename; - if (-e "$localfile") { - my @fileinfo = stat($localfile); - $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode); + if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } + &repcopy($file); + return &readfile($file); +} + +sub repcopy_userfile { + my ($file)=@_; + + if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } + if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; } + + my ($cdom,$cnum,$filename) = + ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); + my ($info,$rtncode); + my $uri="/uploaded/$cdom/$cnum/$filename"; + if (-e "$file") { + my @fileinfo = stat($file); + my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { if ($rtncode eq '404') { - unlink($localfile); + unlink($file); } #my $ua=new LWP::UserAgent; - #my $request=new HTTP::Request('GET',&tokenwrapper($file)); + #my $request=new HTTP::Request('GET',&tokenwrapper($uri)); #my $response=$ua->request($request); #if ($response->is_success()) { # return $response->content; @@ -4919,22 +5057,21 @@ sub getfile { return -1; } if ($info < $fileinfo[9]) { - return &readfile($localfile); + return OK; } $info = ''; - $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { return -1; } } else { - $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); - &logthis("return is $lwpresp"); + my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $request=new HTTP::Request('GET',&tokenwrapper($uri)); my $response=$ua->request($request); if ($response->is_success()) { - return $response->content; + $info=$response->content; } else { return -1; } @@ -4943,6 +5080,7 @@ sub getfile { if ($filename =~ m|^(.+)/[^/]+$|) { push @parts, split(/\//,$1); } + my $path = $perlvar{'lonDocRoot'}.'/userfiles'; foreach my $part (@parts) { $path .= '/'.$part; if (!-e $path) { @@ -4950,24 +5088,23 @@ sub getfile { } } } - open (FILE,">$localfile"); + open(FILE,">$file"); print FILE $info; close(FILE); - if ($caller eq 'uploadrep') { - return 'ok'; - } - return $info; + return OK; } sub tokenwrapper { my $uri=shift; - $uri=~s/^http\:\/\/([^\/]+)//; - $uri=~s/^\///; + $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. + my (undef,$udom,$uname,$file)=split('/',$uri,4); + if ($udom && $uname && $file) { + $file=~s|(\?\.*)*$||; + &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'}); + return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -5012,7 +5149,19 @@ sub filelocation { $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; } elsif ($file=~/^\/*uploaded/) { # is an uploaded file - $location=$file; + my ($udom,$uname,$filename)= + ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); + my $home=&homeserver($uname,$udom); + my $is_me=0; + my @ids=¤t_machine_ids(); + foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } + if ($is_me) { + $location=&Apache::loncommon::propath($udom,$uname). + '/userfiles/'.$filename; + } else { + $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. + $udom.'/'.$uname.'/'.$filename; + } } else { $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; $file=~s:^/res/:/:; @@ -5129,7 +5278,7 @@ sub goodbye { &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))); + &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache))); &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); &flushcourselogs(); @@ -5208,10 +5357,6 @@ BEGIN { $hostip{$id}=$ip; $iphost{$ip}=$id; if ($role eq 'library') { $libserv{$id}=$name; } - } else { - if ($configline) { - &logthis("Skipping hosts.tab line -$configline-"); - } } } close($config); @@ -5515,8 +5660,8 @@ X B: get user privileges =item * -X -B: 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" @@ -5903,6 +6048,17 @@ put($namespace,$storehash,$udom,$uname) =item * +putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp +keys used in storehash include version information (e.g., 1:$symb:message etc.) as +used in records written by &store and retrieved by &restore. This function +was created for use in editing discussion posts, without incrementing the +version number included in the key for a particular post. The colon +separated list of attribute names (e.g., the value associated with the key +1:keys:$symb) is also generated and passed in the ampersand separated +items sent to lonnet::reply(). + +=item * + cput($namespace,$storehash,$udom,$uname) : critical put ($udom and $uname are optional)