--- loncom/lonnet/perl/lonnet.pm 2004/11/10 19:03:04 1.567 +++ loncom/lonnet/perl/lonnet.pm 2005/03/31 15:55:47 1.618 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.567 2004/11/10 19:03:04 raeburn Exp $ +# $Id: lonnet.pm,v 1.618 2005/03/31 15:55:47 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -35,11 +35,11 @@ use HTTP::Headers; use HTTP::Date; # use Date::Parse; use vars -qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom - %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache +qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom + %libserv %pr %prp $memcache %packagetab %courselogs %accesshash %userrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache - %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf + %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); use IO::Socket; @@ -50,6 +50,7 @@ use Fcntl qw(:flock); use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); use Time::HiRes qw( gettimeofday tv_interval ); +use Cache::Memcached; my $readit; my $max_connection_retries = 10; # Or some such value. @@ -157,22 +158,6 @@ sub reply { my ($cmd,$server)=@_; unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { - #sleep 5; - #$answer=subreply($cmd,$server); - #if ($answer eq 'con_lost') { - # &logthis("Second attempt con_lost on $server"); - # my $peerfile="$perlvar{'lonSockDir'}/$server"; - # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", - # Type => SOCK_STREAM, - # Timeout => 10) - # or return "con_lost"; - # &logthis("Killing socket"); - # print $client "close_connection_exit\n"; - #sleep 5; - # $answer=subreply($cmd,$server); - #} - } if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". " $cmd to $server returned $answer"); @@ -220,11 +205,8 @@ sub critical { } my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { - my $pingreply=reply('ping',$server); &reconlonc("$perlvar{'lonSockDir'}/$server"); - my $pongreply=reply('pong',$server); - &logthis("Ping/Pong for $server: $pingreply/$pongreply"); - $answer=reply($cmd,$server); + my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { my $now=time; my $middlename=$cmd; @@ -577,12 +559,12 @@ sub authenticate { # ---------------------- Find the homebase for a user from domain's lib servers +my %homecache; sub homeserver { my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); - if (defined($cached)) { return $result; } + if (exists($homecache{$index})) { return $homecache{$index}; } my $tryserver; foreach $tryserver (keys %libserv) { next if ($ignoreBadCache ne 'true' && @@ -590,7 +572,7 @@ sub homeserver { if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - return &do_cache(\%homecache,$index,$tryserver,'home'); + return $homecache{$index}=$tryserver; } elsif ($answer eq 'no_host') { $badServerCache{$tryserver}=1; } @@ -795,11 +777,12 @@ sub validate_access_key { sub getsection { my ($udom,$unam,$courseid)=@_; + my $cachetime=1800; $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; my $hashid="$udom:$unam:$courseid"; - my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection'); + my ($result,$cached)=&is_cached_new('getsection',$hashid); if (defined($cached)) { return $result; } my %Pending; @@ -834,211 +817,105 @@ sub getsection { $Pending{$start}=$section; next; } - return &do_cache(\%getsectioncache,$hashid,$section,'getsection'); + return &do_cache_new('getsection',$hashid,$section,$cachetime); } # # 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 &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection'); + return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime); } if (scalar(keys(%Expired))) { my @sorted = sort {$a <=> $b} keys(%Expired); my $time = pop(@sorted); - return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection'); + return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime); } - return &do_cache(\%getsectioncache,$hashid,'-1','getsection'); + return &do_cache_new('getsection',$hashid,'-1',$cachetime); } +sub save_cache { + &purge_remembered(); +} -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"); +my $to_remember=-1; +my %remembered; +my %accessed; +my $kicks=0; +my $hits=0; +sub devalidate_cache_new { + my ($name,$id,$debug) = @_; + if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } + $id=&escape($name.':'.$id); + $memcache->delete($id); + delete($remembered{$id}); + delete($accessed{$id}); +} + +sub is_cached_new { + my ($name,$id,$debug) = @_; + $id=&escape($name.':'.$id); + if (exists($remembered{$id})) { + if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } + $accessed{$id}=[&gettimeofday()]; + $hits++; + return ($remembered{$id},1); + } + my $value = $memcache->get($id); + if (!(defined($value))) { + if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } 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; + if ($value eq '__undef__') { + if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } + $value=undef; + } + &make_room($id,$value,$debug); + if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } + return ($value,1); +} + +sub do_cache_new { + my ($name,$id,$value,$time,$debug) = @_; + $id=&escape($name.':'.$id); + my $setvalue=$value; + if (!defined($setvalue)) { + $setvalue='__undef__'; + } + 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; +} + +sub make_room { + my ($id,$value,$debug)=@_; + $remembered{$id}=$value; + if ($to_remember<0) { return; } + $accessed{$id}=[&gettimeofday()]; + if (scalar(keys(%remembered)) <= $to_remember) { return; } + my $to_kick; + my $max_time=0; + foreach my $other (keys(%accessed)) { + if (&tv_interval($accessed{$other}) > $max_time) { + $to_kick=$other; + $max_time=&tv_interval($accessed{$other}); + } + } + delete($remembered{$to_kick}); + delete($accessed{$to_kick}); + $kicks++; + if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); } 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); - 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)); +sub purge_remembered { + #&logthis("Tossing ".scalar(keys(%remembered))); + #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); + undef(%remembered); + undef(%accessed); } - # ------------------------------------- Read an entry from a user's environment sub userenvironment { @@ -1054,6 +931,19 @@ sub userenvironment { return %returnhash; } +# ---------------------------------------------------------- Get a studentphoto +sub studentphoto { + my ($udom,$unam,$ext) = @_; + my $home=&Apache::lonnet::homeserver($unam,$udom); + my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home); + my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext; + if ($ret ne 'ok') { + return '/adm/lonKaputt/lonlogo_broken.gif'; + } + my $tokenurl=&Apache::lonnet::tokenwrapper($url); + return $tokenurl; +} + # -------------------------------------------------------------------- New chat sub chatsend { @@ -1076,7 +966,7 @@ sub getversion { sub currentversion { my $fname=shift; - my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); + my ($result,$cached)=&is_cached_new('resversion',$fname); if (defined($cached)) { return $result; } my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; @@ -1089,7 +979,7 @@ sub currentversion { if (($answer eq 'con_lost') || ($answer eq 'rejected')) { return -1; } - return &do_cache(\%resversioncache,$fname,$answer,'resversion'); + return &do_cache_new('resversion',$fname,$answer,600); } # ----------------------------- Subscribe to a resource, return URL if possible @@ -1117,27 +1007,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/|) { + $filename=~m -^/*(uploaded|editupload)/-) { 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 'unavailable'; } elsif ($remoteurl eq 'not_found') { #&logthis("Subscribe returned not_found: $filename"); - return HTTP_NOT_FOUND; + return '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/; @@ -1148,7 +1038,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 'bad_request'; } my $count; for ($count=5;$count<$#parts;$count++) { @@ -1165,7 +1055,7 @@ sub repcopy { my $message=$response->status_line; &logthis("WARNING:" ." LWP get: $message: $filename"); - return HTTP_SERVICE_UNAVAILABLE; + return 'unavailable'; } else { if ($remoteurl!~/\.meta$/) { my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); @@ -1177,7 +1067,7 @@ sub repcopy { } } rename($transname,$filename); - return OK; + return 'ok'; } } } @@ -1186,6 +1076,9 @@ sub repcopy { # ------------------------------------------------ Get server side include body sub ssi_body { my ($filelink,%form)=@_; + if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { + $form{'LONCAPA_INTERNAL_no_discussion'}='true'; + } my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); $output=~s|//(\s*)?\s||gs; @@ -1319,10 +1212,6 @@ sub process_coursefile { return $fetchresult; } -# --------------- 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 clean_filename { my ($fname)=@_; # Replace Windows backslashes by forward slashes @@ -1339,6 +1228,11 @@ sub clean_filename { return $fname; } +# --------------- 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,$subdir)=@_; if (!defined($subdir)) { $subdir='unknown'; } @@ -1406,10 +1300,9 @@ sub finishuserfileupload { } # Save the file { - #&Apache::lonnet::logthis("Saving to $filepath $file"); - open(my $fh,'>'.$filepath.'/'.$file); - print $fh $ENV{'form.'.$formname}; - close($fh); + open(FH,'>'.$filepath.'/'.$file); + print FH $ENV{'form.'.$formname}; + close(FH); } # Notify homeserver to grep it # @@ -1428,7 +1321,7 @@ sub finishuserfileupload { sub removeuploadedurl { my ($url)=@_; my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); - return &Apache::lonnet::removeuserfile($uname,$udom,$fname); + return &removeuserfile($uname,$udom,$fname); } sub removeuserfile { @@ -1490,12 +1383,12 @@ sub flushcourselogs { if ($courseidbuffer{$coursehombuf{$crsid}}) { $courseidbuffer{$coursehombuf{$crsid}}.='&'. &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - '='.&escape($courseinstcodebuf{$crsid}); + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); } else { $courseidbuffer{$coursehombuf{$crsid}}= &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - '='.&escape($courseinstcodebuf{$crsid}); - } + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); + } } # # Write course id database (reverse lookup) to homeserver of courses @@ -1570,6 +1463,8 @@ sub courselog { $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; $courseinstcodebuf{$ENV{'request.course.id'}}= $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; + $courseownerbuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.internal.courseowner'}; if (defined $courselogs{$ENV{'request.course.id'}}) { $courselogs{$ENV{'request.course.id'}}.='&'.$what; } else { @@ -1586,11 +1481,23 @@ sub courseacclog { my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { $what.=':POST'; + # FIXME: Probably ought to escape things.... foreach (keys %ENV) { if ($_=~/^form\.(.*)/) { $what.=':'.$1.'='.$ENV{$_}; } } + } elsif ($fnsymb =~ m:^/adm/searchcat:) { + # FIXME: We should not be depending on a form parameter that someone + # editing lonsearchcat.pm might change in the future. + if ($ENV{'form.phase'} eq 'course_search') { + $what.= ':POST'; + # FIXME: Probably ought to escape things.... + foreach my $element ('courseexp','crsfulltext','crsrelated', + 'crsdiscuss') { + $what.=':'.$element.'='.$ENV{'form.'.$element}; + } + } } &courselog($what); } @@ -1642,6 +1549,7 @@ sub get_course_adv_roles { if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$_); + if ($username eq '' || $domain eq '') { next; } if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } my $key=&plaintext($role); @@ -1713,7 +1621,7 @@ sub courseidput { } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_; + my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } foreach my $tryserver (keys %libserv) { @@ -1721,7 +1629,8 @@ sub courseiddump { if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { foreach ( split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. - $sincefilter.':'.&escape($descfilter), + $sincefilter.':'.&escape($descfilter).':'. + &escape($instcodefilter).':'.&escape($ownerfilter), $tryserver))) { my ($key,$value)=split(/\=/,$_); if (($key) && ($value)) { @@ -1742,19 +1651,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'; } @@ -1812,7 +1729,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))); @@ -2095,9 +2012,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', @@ -2130,9 +2049,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'; @@ -2144,7 +2065,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'; @@ -2171,10 +2092,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; @@ -2192,8 +2115,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))) { @@ -2234,7 +2157,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); @@ -2270,7 +2193,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); @@ -2304,7 +2227,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++) { @@ -2360,7 +2283,7 @@ sub privileged { my $now=time; if ($rolesdump ne '') { foreach (split(/&/,$rolesdump)) { - if ($_!~/^rolesdef\&/) { + if ($_!~/^rolesdef_/) { my ($area,$role)=split(/=/,$_); $area=~s/\_\w\w$//; my ($trole,$tend,$tstart)=split(/_/,$role); @@ -2392,11 +2315,18 @@ sub rolesinit { if ($rolesdump ne '') { foreach (split(/&/,$rolesdump)) { - if ($_!~/^rolesdef\&/) { + if ($_!~/^rolesdef_/) { my ($area,$role)=split(/=/,$_); - $area=~s/\_\w\w$//; - my ($trole,$tend,$tstart)=split(/_/,$role); - $userroles.=&set_arearole($trole,$area,$tstart,$tend); + $area=~s/\_\w\w$//; + + my ($trole,$tend,$tstart); + if ($role=~/^cr/) { + ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); + ($tend,$tstart)=split('_',$trest); + } else { + ($trole,$tend,$tstart)=split(/_/,$role); + } + $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); if (($tend!=0) && ($tend<$now)) { $trole=''; } if (($tstart!=0) && ($tstart>$now)) { $trole=''; } if (($area ne '') && ($trole ne '')) { @@ -2688,7 +2618,7 @@ sub putstore { my $key = $1.':keys:'.$2; $allitems{$key} .= $3.':'; } - $items.=$_.'='.&escape($$storehash{$_}).'&'; + $items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; } foreach (keys %allitems) { $allitems{$_} =~ s/\:$//; @@ -2773,7 +2703,7 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri)=@_; + my ($priv,$uri,$symb)=@_; $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); @@ -2789,7 +2719,7 @@ sub allowed { # 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) && + if (($space=~/^(uploaded|ediupload)$/) && ($ENV{'user.name'} eq $name) && ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { return 'F'; } @@ -2858,7 +2788,7 @@ sub allowed { } # URI is an uploaded document for this course - +# not allowing 'edit' access (editupload) to uploaded course docs if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { my $refuri=$ENV{'httpref.'.$orguri}; if ($refuri) { @@ -3054,7 +2984,7 @@ sub allowed { if ($thisallowed=~/X/) { if ($ENV{'acc.randomout'}) { - my $symb=&symbread($uri,1); + if (!$symb) { $symb=&symbread($uri,1); } if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { return ''; } @@ -3356,11 +3286,18 @@ sub auto_instcode_format { my $courses = ''; my $homeserver; if ($caller eq 'global') { - $homeserver = $perlvar{'lonHostID'}; + foreach my $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $codedom) { + $homeserver = $tryserver; + last; + } + } + if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) { + $homeserver = &homeserver($ENV{'user.name'},$codedom); + } } else { $homeserver = &homeserver($caller,$codedom); } - my $host=$hostname{$homeserver}; foreach (keys %{$instcodes}) { $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; } @@ -3551,9 +3488,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.', '. @@ -3687,7 +3627,7 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_; + my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_; $url=&declutter($url); my $cid=''; unless (&allowed('ccc',$udom)) { @@ -3722,7 +3662,7 @@ sub createcourse { # ----------------------------------------------------------------- Course made # log existence &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). - '='.&escape($inst_code),$uhome); + ':'.&escape($inst_code).':'.&escape($course_owner),$uhome); &flushcourselogs(); # set toplevel url my $topurl=$url; @@ -3788,8 +3728,11 @@ sub is_locked { my @check; my $is_locked; push @check, $file_name; - my %locked = &Apache::lonnet::get('file_permissions',\@check, - $ENV{'user.domain'},$ENV{'user.name'}); + my %locked = &get('file_permissions',\@check, + $ENV{'user.domain'},$ENV{'user.name'}); + my ($tmp)=keys(%locked); + if ($tmp=~/^error:/) { undef(%locked); } + if (ref($locked{$file_name}) eq 'ARRAY') { $is_locked = 'true'; } else { @@ -3801,19 +3744,94 @@ sub is_locked { sub mark_as_readonly { my ($domain,$user,$files,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + foreach my $file (@{$files}) { push(@{$current_permissions{$file}},$what); } - &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); + &put('file_permissions',\%current_permissions,$domain,$user); return; } +# ------------------------------------------------------------Save Selected Files + +sub save_selected_files { + my ($user, $path, @files) = @_; + my $filename = $user."savedfiles"; + my @other_files = &files_not_in_path($user, $path); + open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + foreach my $file (@files) { + print (OUT $ENV{'form.currentpath'}.$file."\n"); + } + foreach my $file (@other_files) { + print (OUT $file."\n"); + } + close (OUT); + return 'ok'; +} + +sub clear_selected_files { + my ($user) = @_; + my $filename = $user."savedfiles"; + open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + print (OUT undef); + close (OUT); + return ("ok"); +} + +sub files_in_path { + my ($user, $path) = @_; + my $filename = $user."savedfiles"; + my %return_files; + open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + while (my $line_in = ) { + chomp ($line_in); + my @paths_and_file = split (m!/!, $line_in); + my $file_part = pop (@paths_and_file); + my $path_part = join ('/', @paths_and_file); + $path_part.='/'; + my $path_and_file = $path_part.$file_part; + if ($path_part eq $path) { + $return_files{$file_part}= 'selected'; + } + } + close (IN); + return (\%return_files); +} + +# called in portfolio select mode, to show files selected NOT in current directory +sub files_not_in_path { + my ($user, $path) = @_; + my $filename = $user."savedfiles"; + my @return_files; + my $path_part; + open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + while () { + #ok, I know it's clunky, but I want it to work + my @paths_and_file = split m!/!, $_; + my $file_part = pop (@paths_and_file); + chomp ($file_part); + my $path_part = join ('/', @paths_and_file); + $path_part .= '/'; + my $path_and_file = $path_part.$file_part; + if ($path_part ne $path) { + push (@return_files, ($path_and_file)); + } + } + close (OUT); + return (@return_files); +} + #--------------------------------------------------------------Get Marked as Read Only sub get_marked_as_readonly { my ($domain,$user,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + my @readonly_files; while (my ($file_name,$value) = each(%current_permissions)) { if (ref($value) eq "ARRAY"){ @@ -3828,15 +3846,39 @@ sub get_marked_as_readonly { } return @readonly_files; } +#-----------------------------------------------------------Get Marked as Read Only Hash +sub get_marked_as_readonly_hash { + my ($domain,$user,$what) = @_; + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + + my %readonly_files; + while (my ($file_name,$value) = each(%current_permissions)) { + if (ref($value) eq "ARRAY"){ + foreach my $stored_what (@{$value}) { + if ($stored_what eq $what) { + $readonly_files{$file_name} = 'locked'; + } elsif (!defined($what)) { + $readonly_files{$file_name} = 'locked'; + } + } + } + } + return %readonly_files; +} # ------------------------------------------------------------ Unmark as Read Only sub unmark_as_readonly { # unmarks all files locked by $what # for portfolio submissions, $what contains $crsid and $symb my ($domain,$user,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); - my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what); + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + + my @readonly_files = &get_marked_as_readonly($domain,$user,$what); foreach my $file(@readonly_files){ my $current_locks = $current_permissions{$file}; my @new_locks; @@ -3851,12 +3893,12 @@ sub unmark_as_readonly { $current_permissions{$file} = \@new_locks; } else { push(@del_keys, $file); - &Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user); + &del('file_permissions',\@del_keys, $domain, $user); delete $current_permissions{$file}; } } } - &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); + &put('file_permissions',\%current_permissions,$domain,$user); return; } @@ -3884,19 +3926,37 @@ sub dirlist { if($udom) { if($uname) { - my $listing=reply('ls:'.$dirRoot.'/'.$uri, + my $listing=reply('ls2:'.$dirRoot.'/'.$uri, homeserver($uname,$udom)); - return split(/:/,$listing); + my @listing_results; + if ($listing eq 'unknown_cmd') { + $listing=reply('ls:'.$dirRoot.'/'.$uri, + homeserver($uname,$udom)); + @listing_results = split(/:/,$listing); + } else { + @listing_results = map { &unescape($_); } split(/:/,$listing); + } + return @listing_results; } elsif(!defined($alternateDirectoryRoot)) { my $tryserver; my %allusers=(); foreach $tryserver (keys %libserv) { if($hostdom{$tryserver} eq $udom) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. $udom, $tryserver); - if (($listing ne 'no_such_dir') && ($listing ne 'empty') - && ($listing ne 'con_lost')) { - foreach (split(/:/,$listing)) { + my @listing_results; + if ($listing eq 'unknown_cmd') { + $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + @listing_results = split(/:/,$listing); + } else { + @listing_results = + map { &unescape($_); } split(/:/,$listing); + } + if ($listing_results[0] ne 'no_such_dir' && + $listing_results[0] ne 'empty' && + $listing_results[0] ne 'con_lost') { + foreach (@listing_results) { my ($entry,@stat)=split(/&/,$_); $allusers{$entry}=1; } @@ -4024,7 +4084,7 @@ sub condval { sub devalidatecourseresdata { my ($coursenum,$coursedomain)=@_; my $hashid=$coursenum.':'.$coursedomain; - &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); + &devalidate_cache_new('courseres',$hashid); } # --------------------------------------------------- Course Resourcedata Query @@ -4033,18 +4093,18 @@ sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); + my ($result,$cached)=&is_cached_new('courseres',$hashid); unless (defined($cached)) { my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); $result=\%dumpreply; my ($tmp) = keys(%dumpreply); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { - &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + &do_cache_new('courseres',$hashid,$result,600); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } elsif ($tmp =~ /^(error)/) { $result=undef; - &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + &do_cache_new('courseres',$hashid,$result,600); } } foreach my $item (@which) { @@ -4113,7 +4173,8 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - if (defined($Apache::lonhomework::parsing_a_problem)) { + if (defined($Apache::lonhomework::parsing_a_problem) || + defined($Apache::lonhomework::parsing_a_task)) { return $Apache::lonhomework::history{$qualifierrest}; } else { my %restored; @@ -4198,6 +4259,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'}) { @@ -4225,20 +4287,19 @@ 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 if (! &EXT_cache_status($udom,$uname)) { my $hashid="$udom:$uname"; - my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, - 'userres'); + my ($result,$cached)=&is_cached_new('userres',$hashid); if (!defined($cached)) { my %resourcedata=&dump('resourcedata',$udom,$uname); $result=\%resourcedata; - &do_cache(\%userresdatacache,$hashid,$result,'userres'); + &do_cache_new('userres',$hashid,$result); } my ($tmp)=keys(%$result); if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { @@ -4263,13 +4324,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 @@ -4283,7 +4343,7 @@ sub EXT { } if ($thisparm) { return $thisparm; } } -# --------------------------------------------- last, look in resource metadata +# ------------------------------------------ fourth, look in resource metadata $spacequalifierrest=~s/\./\_/; my $filename; @@ -4298,6 +4358,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); @@ -4340,6 +4408,7 @@ sub packages_tab_default { if (defined($packagetab{"$pack_type&$name&default"})) { return $packagetab{"$pack_type&$name&default"}; } + if ($pack_type eq 'part') { $pack_part='0'; } if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { return $packagetab{$pack_type."_".$pack_part."&$name&default"}; } @@ -4365,6 +4434,7 @@ sub add_prefix_and_part { # ---------------------------------------------------------------- Get metadata +my %metaentry; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); @@ -4384,28 +4454,29 @@ sub metadata { # Everything is cached by the main uri, libraries are never directly cached # if (!defined($liburi)) { - my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); + my ($result,$cached)=&is_cached_new('meta',$uri); if (defined($cached)) { return $result->{':'.$what}; } } { # # Is this a recursive call for a library? # - if (! exists($metacache{$uri})) { - $metacache{$uri}={}; - } +# if (! exists($metacache{$uri})) { +# $metacache{$uri}={}; +# } if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; } else { - &devalidate_cache(\%metacache,$uri,'meta'); + &devalidate_cache_new('meta',$uri); + undef(%metaentry); } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri !~ m|^uploaded/|) { + if ($uri !~ m -^(uploaded|editupload)/-) { my $file=&filelocation('',&clutter($filename)); - push(@{$metacache{$uri.'.file'}},$file); + #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); } my $parser=HTML::LCParser->new(\$metastring); @@ -4422,12 +4493,12 @@ sub metadata { if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } - if ($metacache{$uri}->{':packages'}) { - $metacache{$uri}->{':packages'}.=','.$package.$keyroot; + if ($metaentry{':packages'}) { + $metaentry{':packages'}.=','.$package.$keyroot; } else { - $metacache{$uri}->{':packages'}=$package.$keyroot; + $metaentry{':packages'}=$package.$keyroot; } - foreach (keys %packagetab) { + foreach (sort keys %packagetab) { my $part=$keyroot; $part=~s/^\_//; if ($_=~/^\Q$package\E\&/ || @@ -4447,14 +4518,14 @@ sub metadata { if ($subp eq 'display') { $value.=' [Part: '.$part.']'; } - $metacache{$uri}->{':'.$unikey.'.part'}=$part; + $metaentry{':'.$unikey.'.part'}=$part; $metathesekeys{$unikey}=1; - unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { - $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; + unless (defined($metaentry{':'.$unikey.'.'.$subp})) { + $metaentry{':'.$unikey.'.'.$subp}=$value; } - if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { - $metacache{$uri}->{':'.$unikey}= - $metacache{$uri}->{':'.$unikey.'.default'}; + if (defined($metaentry{':'.$unikey.'.default'})) { + $metaentry{':'.$unikey}= + $metaentry{':'.$unikey.'.default'}; } } } @@ -4487,7 +4558,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { - $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; + $metaentry{':'.$_}=$metaentry{':'.$_}; $metathesekeys{$_}=1; } } @@ -4498,18 +4569,18 @@ sub metadata { } $metathesekeys{$unikey}=1; foreach (@{$token->[3]}) { - $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); - my $default=$metacache{$uri}->{':'.$unikey.'.default'}; + my $default=$metaentry{':'.$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; + $metaentry{':'.$unikey}=$default; } else { # either something interesting inside the tag or default # uninteresting - $metacache{$uri}->{':'.$unikey}=$internaltext; + $metaentry{':'.$unikey}=$internaltext; } # end of not-a-package not-a-library import } @@ -4526,7 +4597,7 @@ sub metadata { &metadata_create_package_def($uri,$key,'extension_'.$extension, \%metathesekeys); } - if (!exists($metacache{$uri}->{':packages'})) { + if (!exists($metaentry{':packages'})) { foreach my $key (sort(keys(%packagetab))) { #no specific packages well let's get default then if ($key!~/^default&/) { next; } @@ -4535,31 +4606,31 @@ sub metadata { } } # are there custom rights to evaluate - if ($metacache{$uri}->{':copyright'} eq 'custom') { + if ($metaentry{':copyright'} eq 'custom') { # # Importing a rights file here # unless ($depthcount) { - my $location=$metacache{$uri}->{':customdistributionfile'}; + my $location=$metaentry{':customdistributionfile'}; my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); foreach (sort(split(/\,/,&metadata($uri,'keys', $location,'_rights', $depthcount+1)))) { - $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; + #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } } - $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); - &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); - $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); + $metaentry{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); + $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache_new('meta',$uri,\%metaentry); # this is the end of "was not already recently cached } - return $metacache{$uri}->{':'.$what}; + return $metaentry{':'.$what}; } sub metadata_create_package_def { @@ -4567,22 +4638,22 @@ sub metadata_create_package_def { my ($pack,$name,$subp)=split(/\&/,$key); if ($subp eq 'default') { next; } - if (defined($metacache{$uri}->{':packages'})) { - $metacache{$uri}->{':packages'}.=','.$package; + if (defined($metaentry{':packages'})) { + $metaentry{':packages'}.=','.$package; } else { - $metacache{$uri}->{':packages'}=$package; + $metaentry{':packages'}=$package; } my $value=$packagetab{$key}; my $unikey; $unikey='parameter_0_'.$name; - $metacache{$uri}->{':'.$unikey.'.part'}=0; + $metaentry{':'.$unikey.'.part'}=0; $$metathesekeys{$unikey}=1; - unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { - $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; + unless (defined($metaentry{':'.$unikey.'.'.$subp})) { + $metaentry{':'.$unikey.'.'.$subp}=$value; } - if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { - $metacache{$uri}->{':'.$unikey}= - $metacache{$uri}->{':'.$unikey.'.default'}; + if (defined($metaentry{':'.$unikey.'.default'})) { + $metaentry{':'.$unikey}= + $metaentry{':'.$unikey.'.default'}; } } @@ -4620,8 +4691,11 @@ sub gettitle { my $urlsymb=shift; my $symb=&symbread($urlsymb); if ($symb) { - my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); - if (defined($cached)) { return $result; } + my $key=$ENV{'request.course.id'}."\0".$symb; + my ($result,$cached)=&is_cached_new('title',$key); + if (defined($cached)) { + return $result; + } my ($map,$resid,$url)=&decode_symb($symb); my $title=''; my %bighash; @@ -4633,7 +4707,7 @@ sub gettitle { } $title=~s/\&colon\;/\:/gs; if ($title) { - return &do_cache(\%titlecache,$symb,$title,'title'); + return &do_cache_new('title',$key,$title,600); } $urlsymb=$url; } @@ -4641,7 +4715,23 @@ sub gettitle { if (!$title) { $title=(split('/',$urlsymb))[-1]; } return $title; } - + +sub get_slot { + my ($which,$cnum,$cdom)=@_; + if (!$cnum || !$cdom) { + (undef,my $courseid)=&Apache::lonxml::whichuser(); + $cdom=$ENV{'course.'.$courseid.'.domain'}; + $cnum=$ENV{'course.'.$courseid.'.num'}; + } + my %slotinfo=&get('slots',[$which],$cdom,$cnum); + &Apache::lonhomework::showhash(%slotinfo); + my ($tmp)=keys(%slotinfo); + if ($tmp=~/^error:/) { return (); } + if (ref($slotinfo{$which}) eq 'HASH') { + return %{$slotinfo{$which}}; + } + return $slotinfo{$which}; +} # ------------------------------------------------- Update symbolic store links sub symblist { @@ -4652,7 +4742,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'; @@ -4697,8 +4788,11 @@ sub symbverify { if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { - $okay=1; - } + if (($ENV{'request.role.adv'}) || + $bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) { + $okay=1; + } + } } } untie(%bighash); @@ -4710,7 +4804,7 @@ sub symbverify { sub symbclean { my $symb=shift; - + if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } # remove version from map $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; @@ -4731,19 +4825,20 @@ sub encode_symb { } sub decode_symb { - my ($map,$resid,$url)=split(/\_\_\_/,shift); + my $symb=shift; + if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } + my ($map,$resid,$url)=split(/___/,$symb); return (&fixversion($map),$resid,&fixversion($url)); } sub fixversion { my $fn=shift; - if ($fn=~/^(adm|uploaded|public)/) { return $fn; } + if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; } my %bighash; my $uri=&clutter($fn); my $key=$ENV{'request.course.id'}.'_'.$uri; # is this cached? - my ($result,$cached)=&is_cached(\%courseresversioncache,$key, - 'courseresversion',600); + my ($result,$cached)=&is_cached_new('courseresversion',$key); if (defined($cached)) { return $result; } # unfortunately not cached, or expired if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', @@ -4757,8 +4852,7 @@ sub fixversion { } untie %bighash; } - return &do_cache - (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); + return &do_cache_new('courseresversion',$key,&declutter($uri),600); } sub deversion { @@ -4780,6 +4874,7 @@ sub symbread { } $thisfn=$ENV{'request.filename'}; } + if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } # is that filename actually a symb? Verify, clean, and return if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { if (&symbverify($thisfn,$1)) { @@ -4792,7 +4887,7 @@ sub symbread { my $syval=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { my $targetfn = $thisfn; - if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { + if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { $targetfn = 'adm/wrapper/'.$thisfn; } if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', @@ -4802,13 +4897,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', @@ -4852,7 +4947,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); @@ -4890,8 +4986,25 @@ sub numval2 { return int($total); } +sub numval3 { + use integer; + my $txt=shift; + $txt=~tr/A-J/0-9/; + $txt=~tr/a-j/0-9/; + $txt=~tr/K-T/0-9/; + $txt=~tr/k-t/0-9/; + $txt=~tr/U-Z/0-5/; + $txt=~tr/u-z/0-5/; + $txt=~s/\D//g; + my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); + my $total; + foreach my $val (@txts) { $total+=$val; } + if ($_64bit) { $total=(($total<<32)>>32); } + return $total; +} + sub latest_rnd_algorithm_id { - return '64bit3'; + return '64bit4'; } sub get_rand_alg { @@ -4911,8 +5024,9 @@ sub validCODE { sub getCODE { if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } - if (defined($Apache::lonhomework::parsing_a_problem) && - &validCODE($Apache::lonhomework::history{'resource.CODE'})) { + if ( (defined($Apache::lonhomework::parsing_a_problem) || + defined($Apache::lonhomework::parsing_a_task) ) && + &validCODE($Apache::lonhomework::history{'resource.CODE'})) { return $Apache::lonhomework::history{'resource.CODE'}; } return undef; @@ -4930,7 +5044,13 @@ sub rndseed { if (!$username) { $username=$wusername } my $which=&get_rand_alg(); if (defined(&getCODE())) { - return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + if ($which eq '64bit4') { + return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); + } else { + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } + } elsif ($which eq '64bit4') { + return &rndseed_64bit4($symb,$courseid,$domain,$username); } elsif ($which eq '64bit3') { return &rndseed_64bit3($symb,$courseid,$domain,$username); } elsif ($which eq '64bit2') { @@ -5027,6 +5147,30 @@ sub rndseed_64bit3 { } } +sub rndseed_64bit4 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + # strings need to be an even # of cahracters long, it it is odd the + # last characters gets thrown away + my $symbchck=unpack("%32S*",$symb.' ') << 21; + my $symbseed=numval3($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval3($username) << 21; + my $domainseed=unpack("%32S*",$domain.' ') << 10; + my $courseseed=unpack("%32S*",$courseid.' '); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); + if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } + + return "$num1:$num2"; + } +} + sub rndseed_CODE_64bit { my ($symb,$courseid,$domain,$username)=@_; { @@ -5046,6 +5190,25 @@ sub rndseed_CODE_64bit { } } +sub rndseed_CODE_64bit4 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb.' ') << 16; + my $symbseed=numval3($symb); + my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; + my $CODEseed=numval3(&getCODE()); + my $courseseed=unpack("%32S*",$courseid.' '); + my $num1=$symbseed+$CODEchck; + my $num2=$CODEseed+$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); + if ($_64bit) { $num1=(($num1<<32)>>32); } + if ($_64bit) { $num2=(($num2<<32)>>32); } + return "$num1:$num2"; + } +} + sub setup_random_from_rndseed { my ($rndseed)=@_; if ($rndseed =~/([,:])/) { @@ -5133,18 +5296,15 @@ sub receipt { sub getfile { my ($file) = @_; - - if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } + if ($file =~ m -^/*(uploaded|editupload)/-) { $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; } - + if ($file =~ m -^/*(uploaded|editupload)/-) { $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); @@ -5167,7 +5327,7 @@ sub repcopy_userfile { return -1; } if ($info < $fileinfo[9]) { - return OK; + return 'ok'; } $info = ''; $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); @@ -5201,7 +5361,7 @@ sub repcopy_userfile { open(FILE,">$file"); print FILE $info; close(FILE); - return OK; + return 'ok'; } sub tokenwrapper { @@ -5252,39 +5412,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|editupload)/) { # is an uploaded file + my ($udom,$uname,$filename)= + ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); + 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 { @@ -5330,6 +5490,7 @@ sub current_machine_ids { sub declutter { my $thisfn=shift; + if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; $thisfn=~s/^\///; $thisfn=~s/^res\///; @@ -5341,7 +5502,7 @@ sub declutter { sub clutter { my $thisfn='/'.&declutter(shift); - unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { + unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { $thisfn='/res'.$thisfn; } return $thisfn; @@ -5383,10 +5544,10 @@ sub thaw_unescape { } sub mod_perl_version { + return 1; if (defined($perlvar{'MODPERL2'})) { return 2; } - return 1; } sub correct_line_ends { @@ -5399,17 +5560,20 @@ sub correct_line_ends { sub goodbye { &logthis("Starting Shut down"); #not converted to using infrastruture and probably shouldn't be - &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); + &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); #converted - &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); - &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); - &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); - &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); +# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); + &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 - &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); - &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache))); - &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); - &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); +# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); +# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); +# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); +# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); + &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); + &logthis(sprintf("%-20s is %s",'kicks',$kicks)); + &logthis(sprintf("%-20s is %s",'hits',$hits)); &flushcourselogs(); &logthis("Shutting down"); return DONE; @@ -5419,6 +5583,7 @@ BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { + # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block open(my $config,") { @@ -5479,18 +5644,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"); @@ -5554,7 +5733,7 @@ BEGIN { } -%metacache=(); +$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; @@ -5565,7 +5744,7 @@ $readit=1; { use integer; my $test=(2**32)+1; - if ($test != 0) { $_64bit=1; } + if ($test != 0) { $_64bit=1; } else { $_64bit=0; } &logthis(" Detected 64bit platform ($_64bit)"); } } @@ -5999,8 +6178,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 +'unavailable', 'not_found', 'forbidden', 'ok', or +'bad_request', also attempts to grab the metadata for the resource. Expects the local filesystem pathname (/home/httpd/html/res/....) @@ -6054,9 +6233,10 @@ returns the data handle =item * symbverify($symb,$thisfn) : verifies that $symb actually exists and is -a possible symb for the URL in $thisfn, returns a 1 on success, 0 on -failure, user must be in a course, as it assumes the existance of the -course initi hash, and uses $ENV('request.course.id'} +a possible symb for the URL in $thisfn, and if is an encryypted +resource that the user accessed using /enc/ returns a 1 on success, 0 +on failure, user must be in a course, as it assumes the existance of +the course initial hash, and uses $ENV('request.course.id'} =item * @@ -6341,6 +6521,91 @@ declutter() : declutters URLs (remove do =back +=head2 Usererfile file routines (/uploaded*) + +=over 4 + +=item * + +userfileupload(): main rotine for putting a file in a user or course's + filespace, arguments are, + + formname - required - this is the name of the element in $ENV where the + filename, and the contents of the file to create/modifed exist + the filename is in $ENV{'form.'.$formname.'.filename'} and the + contents of the file is located in $ENV{'form.'.$formname} + coursedoc - if true, store the file in the course of the active role + of the current user + subdir - required - subdirectory to put the file in under ../userfiles/ + if undefined, it will be placed in "unknown" + + (This routine calls clean_filename() to remove any dangerous + characters from the filename, and then calls finuserfileupload() to + complete the transaction) + + returns either the url of the uploaded file (/uploaded/....) if successful + and /adm/notfound.html if unsuccessful + +=item * + +clean_filename(): routine for cleaing a filename up for storage in + userfile space, argument is: + + filename - proposed filename + +returns: the new clean filename + +=item * + +finishuserfileupload(): routine that creaes and sends the file to +userspace, probably shouldn't be called directly + + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + docuhome: loncapa id of the library server that is getting the file + formname: same as for userfileupload() + fname: filename (inculding subdirectories) for the file + + returns either the url of the uploaded file (/uploaded/....) if successful + and /adm/notfound.html if unsuccessful + +=item * + +renameuserfile(): renames an existing userfile to a new name + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + old: current file name (including any subdirs under userfiles) + new: desired file name (including any subdirs under userfiles) + +=item * + +mkdiruserfile(): creates a directory is a userfiles dir + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + dir: dir to create (including any subdirs under userfiles) + +=item * + +removeuserfile(): removes a file that exists in userfiles + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + fname: filname to delete (including any subdirs under userfiles) + +=item * + +removeuploadedurl(): convience function for removeuserfile() + + Args: + url: a full /uploaded/... url to delete + +=back + =head2 HTTP Helper Routines =over 4 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.