--- loncom/lonnet/perl/lonnet.pm 2004/11/06 21:27:40 1.523.2.12 +++ loncom/lonnet/perl/lonnet.pm 2004/07/22 23:08:44 1.524 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.523.2.12 2004/11/06 21:27:40 albertel Exp $ +# $Id: lonnet.pm,v 1.524 2004/07/22 23:08:44 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -40,7 +40,7 @@ qw(%perlvar %hostname %homecache %badSer %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def - %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); + %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); use IO::Socket; use GDBM_File; @@ -50,7 +50,7 @@ use Fcntl qw(:flock); use Apache::loncoursedata; use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); -use Time::HiRes qw( gettimeofday tv_interval ); +use Time::HiRes(); my $readit; =pod @@ -795,11 +795,11 @@ sub getsection { if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); my $now=time; - if (defined($end) && $end && ($now > $end)) { + if (defined($end) && ($now > $end)) { $Expired{$end}=$section; next; } - if (defined($start) && $start && ($now < $start)) { + if (defined($start) && ($now < $start)) { $Pending{$start}=$section; next; } @@ -826,12 +826,10 @@ 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; } + if ($disk_caching_disabled) { return; } my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - if (!-e $filename) { return; } - open(DB,">$filename.lock"); + open(DB,"$filename.lock"); flock(DB,LOCK_EX); my %hash; if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { @@ -858,32 +856,16 @@ sub is_cached { my ($cache,$id,$name,$time) = @_; if (!$time) { $time=300; } if (!exists($$cache{$id.'.time'})) { - &load_cache_item($cache,$name,$id,$time); + &load_cache_item($cache,$name,$id); } 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); - } +# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); + &devalidate_cache($cache,$id,$name); + return (undef,undef); } } return ($$cache{$id},1); @@ -899,69 +881,44 @@ 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; } - $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'}}); - } + 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}}); 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); - } + if ($@) { + &logthis("save_cache blew up :$@:$name"); + unlink($filename); + } + } else { + if (-e $filename) { + &logthis("Unable to tie hash (save cache item): $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); - + untie(%hash); + flock(DB,LOCK_UN); + close(DB); +# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime)); } sub load_cache_item { - my ($cache,$name,$id,$time)=@_; + my ($cache,$name,$id)=@_; 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"); + open(DB,"$filename.lock"); flock(DB,LOCK_SH); if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { eval <<'EVALBLOCK'; @@ -978,17 +935,9 @@ sub load_cache_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'}; - } - } + my $hashref=thaw($hash{$id}); + $$cache{$id}=$hashref->{'item'}; + $$cache{$id.'.time'}=$hash{$id.'.time'}; } EVALBLOCK if ($@) { @@ -1098,7 +1047,6 @@ 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); @@ -1119,7 +1067,6 @@ sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } - $filename=~s/[\n\r]//g; my $transname="$filename.in.transfer"; if ((-e $filename) || (-e $transname)) { return OK; } my $remoteurl=subscribe($filename); @@ -2644,6 +2591,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 { @@ -3132,10 +3103,8 @@ 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); } @@ -3150,16 +3119,6 @@ sub fetch_enrollment_query { my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; } my $reply = &get_query_reply($queryid); - 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); - } unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { my @responses = split/:/,$reply; if ($homeserver eq $perlvar{'lonHostID'}) { @@ -4059,14 +4018,11 @@ 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]; @@ -4077,11 +4033,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=&usection($udom,$uname,$courseid); + } else { + $section = $usection; + } } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -4119,7 +4075,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; } @@ -4129,10 +4085,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 @@ -4265,9 +4221,7 @@ sub metadata { unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; if ($uri !~ m|^uploaded/|) { - my $file=&filelocation('',&clutter($filename)); - push(@{$metacache{$uri.'.file'}},$file); - $metastring=&getfile($file); + $metastring=&getfile(&filelocation('',&clutter($filename))); } my $parser=HTML::LCParser->new(\$metastring); my $token; @@ -4632,20 +4586,14 @@ 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 $ENV{$cache_str}=&symbclean($ENV{'request.symb'}); - } + if ($ENV{'request.symb'}) { return &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 $ENV{$cache_str}=&symbclean($thisfn); - } + if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } } $thisfn=declutter($thisfn); my %hash; @@ -4666,7 +4614,7 @@ sub symbread { unless ($syval=~/\_\d+$/) { unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { &appenv('request.ambiguous' => $thisfn); - return $ENV{$cache_str}=''; + return ''; } $syval.=$1; } @@ -4713,11 +4661,11 @@ sub symbread { } } if ($syval) { - return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); + return &symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); - return $ENV{$cache_str}=''; + return ''; } # ---------------------------------------------------------- Return random seed @@ -4731,7 +4679,6 @@ sub numval { $txt=~tr/U-Z/0-5/; $txt=~tr/u-z/0-5/; $txt=~s/\D//g; - if ($_64bit) { if ($txt > 2**32) { return -1; } } return int($txt); } @@ -4747,7 +4694,6 @@ sub numval2 { my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); my $total; foreach my $val (@txts) { $total+=$val; } - if ($_64bit) { if ($total > 2**32) { return -1; } } return int($total); } @@ -4764,16 +4710,10 @@ sub get_rand_alg { return &latest_rnd_algorithm_id(); } -sub validCODE { - my ($CODE)=@_; - if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; } - return 0; -} - sub getCODE { - if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } + if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } if (defined($Apache::lonhomework::parsing_a_problem) && - &validCODE($Apache::lonhomework::history{'resource.CODE'})) { + defined($Apache::lonhomework::history{'resource.CODE'})) { return $Apache::lonhomework::history{'resource.CODE'}; } return undef; @@ -4815,7 +4755,6 @@ sub rndseed_32bit { my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); #&Apache::lonxml::debug("rndseed :$num:$symb"); - if ($_64bit) { $num=(($num<<32)>>32); } return $num; } } @@ -4836,7 +4775,6 @@ sub rndseed_64bit { my $num2=$nameseed+$domainseed+$courseseed; #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); #&Apache::lonxml::debug("rndseed :$num:$symb"); - if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1,$num2"; } } @@ -4859,7 +4797,6 @@ sub rndseed_64bit2 { my $num2=$nameseed+$domainseed+$courseseed; #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); #&Apache::lonxml::debug("rndseed :$num:$symb"); - if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1,$num2"; } } @@ -4881,9 +4818,7 @@ sub rndseed_64bit3 { 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); } - + #&Apache::lonxml::debug("rndseed :$num:$symb"); return "$num1:$num2"; } } @@ -4901,8 +4836,6 @@ sub rndseed_CODE_64bit { 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"; } } @@ -5394,12 +5327,6 @@ $dumpcount=0; &logtouch(); &logthis('INFO: Read configuration'); $readit=1; - { - use integer; - my $test=(2**32)+1; - if ($test != 0) { $_64bit=1; } - &logthis(" Detected 64bit platform ($_64bit)"); - } } } @@ -6015,6 +5942,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)