--- loncom/lonnet/perl/lonnet.pm 2005/04/15 20:48:18 1.587.2.3.2.16 +++ loncom/lonnet/perl/lonnet.pm 2005/03/03 05:45:50 1.603 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.587.2.3.2.16 2005/04/15 20:48:18 albertel Exp $ +# $Id: lonnet.pm,v 1.603 2005/03/03 05:45:50 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -35,7 +35,7 @@ use HTTP::Headers; use HTTP::Date; # use Date::Parse; use vars -qw(%perlvar %hostname %badServerCache %hostip %iphost %spareid %hostdom +qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom %libserv %pr %prp $memcache %packagetab %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf @@ -834,193 +834,8 @@ sub getsection { return &do_cache_new('getsection',$hashid,'-1',$cachetime); } - -my $disk_caching_disabled=1; - -sub devalidate_cache { - my ($cache,$id,$name) = @_; - delete $$cache{$id.'.time'}; - delete $$cache{$id.'.file'}; - delete $$cache{$id}; - if (1 || $disk_caching_disabled) { return; } - my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - if (!-e $filename) { return; } - open(DB,">$filename.lock"); - flock(DB,LOCK_EX); - my %hash; - if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { - eval <<'EVALBLOCK'; - delete($hash{$id}); - delete($hash{$id.'.time'}); -EVALBLOCK - if ($@) { - &logthis("devalidate_cache blew up :$@:$name"); - unlink($filename); - } - } else { - if (-e $filename) { - &logthis("Unable to tie hash (devalidate cache): $name"); - unlink($filename); - } - } - untie(%hash); - flock(DB,LOCK_UN); - close(DB); -} - -sub is_cached { - my ($cache,$id,$name,$time) = @_; - if (!$time) { $time=300; } - if (!exists($$cache{$id.'.time'})) { - &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) { - 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); -} - -sub do_cache { - my ($cache,$id,$value,$name) = @_; - $$cache{$id.'.time'}=time; - $$cache{$id}=$value; -# &logthis("Caching $id as :$value:"); - &save_cache_item($cache,$name,$id); - # do_cache implictly return the set value - $$cache{$id}; -} - -my %do_save_item; -my %do_save; -sub save_cache_item { - my ($cache,$name,$id)=@_; - if ($disk_caching_disabled) { return; } - $do_save{$name}=$cache; - if (!exists($do_save_item{$name})) { $do_save_item{$name}={} } - $do_save_item{$name}->{$id}=1; - return; -} - sub save_cache { &purge_remembered(); - 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); - 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)); - } - undef(%do_save); - undef(%do_save_item); - -} - -sub load_cache_item { - 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"; - if (!-e $filename) { return; } - open(DB,">$filename.lock"); - flock(DB,LOCK_SH); - if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { - eval <<'EVALBLOCK'; - if (!%$cache) { - my $count; - while (my ($key,$value)=each(%hash)) { - $count++; - if ($key =~ /\.time$/) { - $$cache{$key}=$value; - } else { - my $hashref=thaw($value); - $$cache{$key}=$hashref->{'item'}; - } - } -# &logthis("Initial load: $count"); - } else { - 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 ($@) { - &logthis("load_cache blew up :$@:$name"); - unlink($filename); - } - } else { - if (-e $filename) { - &logthis("Unable to tie hash (load cache item): $name ($!)"); - unlink($filename); - } - } - untie(%hash); - flock(DB,LOCK_UN); - close(DB); -# &logthis("After Loading $name size is ".scalar(%$cache)); -# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); } my $to_remember=-1; @@ -1067,11 +882,9 @@ sub do_cache_new { if (!defined($setvalue)) { $setvalue='__undef__'; } - if (!defined($time)) { - $time=600; - } if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } $memcache->set($id,$setvalue,$time); + # need to make a copy of $value #&make_room($id,$value,$debug); return $value; } @@ -1093,7 +906,7 @@ sub make_room { delete($remembered{$to_kick}); delete($accessed{$to_kick}); $kicks++; - if ($debug) { &logthis("kicking $max_time $kicks\n"); } + if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); } return; } @@ -1181,27 +994,27 @@ sub subscribe { sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; - if ($filename=~m|^/home/httpd/html/adm/|) { return OK; } - if ($filename=~m|^/home/httpd/html/lonUsers/|) { 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; } + if ((-e $filename) || (-e $transname)) { return 'OK'; } my $remoteurl=subscribe($filename); if ($remoteurl =~ /^con_lost by/) { &logthis("Subscribe returned $remoteurl: $filename"); - return HTTP_SERVICE_UNAVAILABLE; + return 'HTTP_SERVICE_UNAVAILABLE'; } elsif ($remoteurl eq 'not_found') { #&logthis("Subscribe returned not_found: $filename"); - return HTTP_NOT_FOUND; + return 'HTTP_NOT_FOUND'; } elsif ($remoteurl =~ /^rejected by/) { &logthis("Subscribe returned $remoteurl: $filename"); - return FORBIDDEN; + return 'FORBIDDEN'; } elsif ($remoteurl eq 'directory') { - return OK; + return 'OK'; } else { my $author=$filename; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; @@ -1212,7 +1025,7 @@ sub repcopy { my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; if ($path ne "$perlvar{'lonDocRoot'}/res") { &logthis("Malconfiguration for replication: $filename"); - return HTTP_BAD_REQUEST; + return 'HTTP_BAD_REQUEST'; } my $count; for ($count=5;$count<$#parts;$count++) { @@ -1229,7 +1042,7 @@ sub repcopy { my $message=$response->status_line; &logthis("WARNING:" ." LWP get: $message: $filename"); - return HTTP_SERVICE_UNAVAILABLE; + return 'HTTP_SERVICE_UNAVAILABLE'; } else { if ($remoteurl!~/\.meta$/) { my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); @@ -1241,7 +1054,7 @@ sub repcopy { } } rename($transname,$filename); - return OK; + return 'OK'; } } } @@ -1822,19 +1635,27 @@ sub get_first_access { my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); if ($argsymb) { $symb=$argsymb; } my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { $res=$map; } - my %times=&get('firstaccesstimes',[$res],$udom,$uname); - return $times{$res}; + if ($type eq 'map') { + $res=&symbread($map); + } else { + $res=$symb; + } + my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); + return $times{"$courseid\0$res"}; } sub set_first_access { my ($type)=@_; my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { $res=$map; } - my $firstaccess=&get_first_access($type); + if ($type eq 'map') { + $res=&symbread($map); + } else { + $res=$symb; + } + my $firstaccess=&get_first_access($type,$symb); if (!$firstaccess) { - return &put('firstaccesstimes',{$res=>time},$udom,$uname); + return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); } return 'already_set'; } @@ -1892,7 +1713,7 @@ sub checkin { my $now=time; my ($ta,$tb,$lonhost)=split(/\*/,$token); $lonhost=~tr/A-Z/a-z/; - my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; + my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; $dtoken=~s/\W/\_/g; my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); @@ -2175,9 +1996,11 @@ sub tmpreset { $namespace=~s/\//\_/g; $namespace=~s/\W//g; - #FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my $path=$perlvar{'lonDaemons'}.'/tmp'; my %hash; if (tie(%hash,'GDBM_File', @@ -2210,9 +2033,11 @@ sub tmpstore { } $namespace=~s/\//\_/g; $namespace=~s/\W//g; -#FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my $now=time; my %hash; my $path=$perlvar{'lonDaemons'}.'/tmp'; @@ -2224,7 +2049,7 @@ sub tmpstore { my $allkeys=''; foreach my $key (keys(%$storehash)) { $allkeys.=$key.':'; - $hash{"$version:$symb:$key"}=$$storehash{$key}; + $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key}); } $hash{"$version:$symb:timestamp"}=$now; $allkeys.='timestamp'; @@ -2251,10 +2076,12 @@ sub tmprestore { $symb=escape($symb); if (!$namespace) { $namespace=$ENV{'request.state'}; } - #FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } - + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my %returnhash; $namespace=~s/\//\_/g; $namespace=~s/\W//g; @@ -2272,8 +2099,8 @@ sub tmprestore { my $key; $returnhash{"$scope:keys"}=$vkeys; foreach $key (@keys) { - $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; - $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; + $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); + $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); } } if (!(untie(%hash))) { @@ -2314,7 +2141,7 @@ sub store { my $namevalue=''; foreach (keys %$storehash) { - $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); @@ -2350,7 +2177,7 @@ sub cstore { my $namevalue=''; foreach (keys %$storehash) { - $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); @@ -2384,7 +2211,7 @@ sub restore { my %returnhash=(); foreach (split(/\&/,$answer)) { my ($name,$value)=split(/\=/,$_); - $returnhash{&unescape($name)}=&unescape($value); + $returnhash{&unescape($name)}=&thaw_unescape($value); } my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { @@ -2775,7 +2602,7 @@ sub putstore { my $key = $1.':keys:'.$2; $allitems{$key} .= $3.':'; } - $items.=$_.'='.&escape($$storehash{$_}).'&'; + $items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; } foreach (keys %allitems) { $allitems{$_} =~ s/\:$//; @@ -3645,9 +3472,12 @@ sub modifyuser { if (defined($middle)) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } if (defined($gene)) { $names{'generation'} = $gene; } - if ($email) { $names{'notification'} = $email; - $names{'critnotification'} = $email; } - + if ($email) { + $email=~s/[^\w\@\.\-\,]//gs; + if ($email=~/\@/) { $names{'notification'} = $email; + $names{'critnotification'} = $email; + $names{'permanentemail'} = $email; } + } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. @@ -4379,6 +4209,7 @@ sub EXT { if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { if (!$symbparm) { $symbparm=&symbread(); } } + my ($courselevelm,$courselevel); if ($symbparm && defined($courseid) && $courseid eq $ENV{'request.course.id'}) { @@ -4406,9 +4237,9 @@ sub EXT { my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; - my $courselevel=$courseid.'.'.$spacequalifierrest; + $courselevel=$courseid.'.'.$spacequalifierrest; my $courselevelr=$courseid.'.'.$symbparm; - my $courselevelm=$courseid.'.'.$mapparm; + $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user #most student don\'t have any data set, check if there is some data @@ -4418,7 +4249,7 @@ sub EXT { if (!defined($cached)) { my %resourcedata=&dump('resourcedata',$udom,$uname); $result=\%resourcedata; - &do_cache_new('userres',$hashid,$result,600); + &do_cache_new('userres',$hashid,$result); } my ($tmp)=keys(%$result); if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { @@ -4443,13 +4274,12 @@ sub EXT { } } -# -------------------------------------------------------- second, check course +# ------------------------------------------------ second, check some of course my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, $ENV{'course.'.$courseid.'.domain'}, ($seclevelr,$seclevelm,$seclevel, - $courselevelr,$courselevelm, - $courselevel)); + $courselevelr)); if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms @@ -4463,7 +4293,7 @@ sub EXT { } if ($thisparm) { return $thisparm; } } -# --------------------------------------------- last, look in resource metadata +# ------------------------------------------ fourth, look in resource metadata $spacequalifierrest=~s/\./\_/; my $filename; @@ -4478,6 +4308,14 @@ sub EXT { $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); if (defined($metadata)) { return $metadata; } +# ---------------------------------------------- fourth, look in rest pf course + if ($symbparm && defined($courseid) && + $courseid eq $ENV{'request.course.id'}) { + my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, + $ENV{'course.'.$courseid.'.domain'}, + ($courselevelm,$courselevel)); + if (defined($coursereply)) { return $coursereply; } + } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { my @parts=split(/_/,$space); @@ -4739,7 +4577,7 @@ sub metadata { $metaentry{':keys'}=join(',',keys %metathesekeys); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache_new('meta',$uri,\%metaentry,6000); + &do_cache_new('meta',$uri,\%metaentry); # this is the end of "was not already recently cached } return $metaentry{':'.$what}; @@ -4838,7 +4676,8 @@ sub symblist { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT(),0640)) { foreach (keys %newhash) { - $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_}); + $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1], + $newhash{$_}->[0]); } if (untie(%hash)) { return 'ok'; @@ -4992,13 +4831,13 @@ sub symbread { } # ---------------------------------------------------------- There was an entry if ($syval) { - unless ($syval=~/\_\d+$/) { - unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { - &appenv('request.ambiguous' => $thisfn); - return $ENV{$cache_str}=''; - } - $syval.=$1; - } + #unless ($syval=~/\_\d+$/) { + #unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { + #&appenv('request.ambiguous' => $thisfn); + #return $ENV{$cache_str}=''; + #} + #$syval.=$1; + #} } else { # ------------------------------------------------------- Was not in symb table if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', @@ -5042,7 +4881,8 @@ sub symbread { } } if ($syval) { - return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); + return $ENV{$cache_str}=$syval; + #return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); @@ -5397,10 +5237,8 @@ sub getfile { sub repcopy_userfile { my ($file)=@_; - if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } - if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; } - + if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'OK'; } my ($cdom,$cnum,$filename) = ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); my ($info,$rtncode); @@ -5423,7 +5261,7 @@ sub repcopy_userfile { return -1; } if ($info < $fileinfo[9]) { - return OK; + return 'OK'; } $info = ''; $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); @@ -5457,7 +5295,7 @@ sub repcopy_userfile { open(FILE,">$file"); print FILE $info; close(FILE); - return OK; + return 'OK'; } sub tokenwrapper { @@ -5508,39 +5346,39 @@ sub readfile { } sub filelocation { - my ($dir,$file) = @_; - my $location; - $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces - if ($file=~m:^/~:) { # is a contruction space reference - $location = $file; - $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; - } elsif ($file=~/^\/*uploaded/) { # is an uploaded 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/:/:; - if ( !( $file =~ m:^/:) ) { - $location = $dir. '/'.$file; + my ($dir,$file) = @_; + my $location; + $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces + if ($file=~m:^/~:) { # is a contruction space reference + $location = $file; + $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded 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 { - $location = '/home/httpd/html/res'.$file; + $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; + $file=~s:^/res/:/:; + if ( !( $file =~ m:^/:) ) { + $location = $dir. '/'.$file; + } else { + $location = '/home/httpd/html/res'.$file; + } } - } - $location=~s://+:/:g; # remove duplicate / - while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. - while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ - return $location; + $location=~s://+:/:g; # remove duplicate / + while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ + return $location; } sub hreflocation { @@ -5659,7 +5497,7 @@ sub goodbye { &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); #converted # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); -# &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); + &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); # &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); # &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); #1.1 only @@ -5740,18 +5578,32 @@ BEGIN { while (my $configline=<$config>) { next if ($configline =~ /^(\#|\s*$)/); chomp($configline); - my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); - if ($id && $domain && $role && $name && $ip) { + my ($id,$domain,$role,$name)=split(/:/,$configline); + $name=~s/\s//g; + if ($id && $domain && $role && $name) { $hostname{$id}=$name; $hostdom{$id}=$domain; - $hostip{$id}=$ip; - $iphost{$ip}=$id; if ($role eq 'library') { $libserv{$id}=$name; } } } close($config); } +sub get_iphost { + if (%iphost) { return %iphost; } + foreach my $id (keys(%hostname)) { + my $name=$hostname{$id}; + my $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found\n"); + next; + } + $ip=inet_ntoa($ip); + push(@{$iphost{$ip}},$id); + } + return %iphost; +} + # ------------------------------------------------------ Read spare server file { open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); @@ -6260,8 +6112,8 @@ subscribe($fname) : subscribe to a resou repcopy($filename) : subscribes to the requested file, and attempts to replicate from the owning library server, Might return -HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or -HTTP_BAD_REQUEST, also attempts to grab the metadata for the +'HTTP_SERVICE_UNAVAILABLE', 'HTTP_NOT_FOUND', 'FORBIDDEN', 'OK', or +'HTTP_BAD_REQUEST', also attempts to grab the metadata for the resource. Expects the local filesystem pathname (/home/httpd/html/res/....)