--- loncom/lonnet/perl/lonnet.pm 2003/03/26 19:34:42 1.355 +++ loncom/lonnet/perl/lonnet.pm 2003/07/18 19:50:28 1.392 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.355 2003/03/26 19:34:42 www Exp $ +# $Id: lonnet.pm,v 1.392 2003/07/18 19:50:28 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -243,6 +243,26 @@ sub critical { } return $answer; } + +# ------------------------------------------- Transfer profile into environment + +sub transfer_profile_to_env { + my ($lonidsdir,$handle)=@_; + my @profile; + { + my $idf=Apache::File->new("$lonidsdir/$handle.id"); + flock($idf,LOCK_SH); + @profile=<$idf>; + $idf->close(); + } + my $envi; + for ($envi=0;$envi<=$#profile;$envi++) { + chomp($profile[$envi]); + my ($envname,$envvalue)=split(/=/,$profile[$envi]); + $ENV{$envname} = $envvalue; + } + $ENV{'user.environment'} = "$lonidsdir/$handle.id"; +} # ---------------------------------------------------------- Append Environment @@ -347,6 +367,30 @@ sub delenv { return 'ok'; } +# ------------------------------------------ Find out current server userload +# there is a copy in lond +sub userload { + my $numusers=0; + { + opendir(LONIDS,$perlvar{'lonIDsDir'}); + my $filename; + my $curtime=time; + while ($filename=readdir(LONIDS)) { + if ($filename eq '.' || $filename eq '..') {next;} + my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8]; + if ($curtime-$atime < 3600) { $numusers++; } + } + closedir(LONIDS); + } + my $userloadpercent=0; + my $maxuserload=$perlvar{'lonUserLoadLim'}; + if ($maxuserload) { + $userloadpercent=100*$numusers/$maxuserload; + } + $userloadpercent=sprintf("%.2f",$userloadpercent); + return $userloadpercent; +} + # ------------------------------------------ Fight off request when overloaded sub overloaderror { @@ -373,17 +417,23 @@ sub overloaderror { # ------------------------------ Find server with least workload from spare.tab sub spareserver { - my $loadpercent = shift; + my ($loadpercent,$userloadpercent) = @_; my $tryserver; my $spareserver=''; - my $lowestserver=$loadpercent; + if ($userloadpercent !~ /\d/) { $userloadpercent=0; } + my $lowestserver=$loadpercent > $userloadpercent? + $loadpercent : $userloadpercent; foreach $tryserver (keys %spareid) { - my $answer=reply('load',$tryserver); + my $loadans=reply('load',$tryserver); + my $userloadans=reply('userload',$tryserver); + if ($userloadans !~ /\d/) { $userloadans=0; } + my $answer=$loadans > $userloadans? + $loadans : $userloadans; if (($answer =~ /\d/) && ($answer<$lowestserver)) { $spareserver="http://$hostname{$tryserver}"; $lowestserver=$answer; } - } + } return $spareserver; } @@ -591,7 +641,11 @@ sub idput { # --------------------------------------------------- Assign a key to a student sub assign_access_key { - my ($ckey,$cdom,$cnum,$udom,$uname)=@_; +# +# a valid key looks like uname:udom#comments +# comments are being appended +# + my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_; $cdom= $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= @@ -599,13 +653,16 @@ sub assign_access_key { $udom=$ENV{'user.name'} unless (defined($udom)); $uname=$ENV{'user.domain'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); - if (($existing{$ckey}=~/^\d+$/) || # has time - new key - ($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen, + if (($existing{$ckey}=~/^\#(.*)$/) || # - new key + ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { + # assigned to this person + # - this should not happen, # unless something went wrong # the first time around # ready to assign - } elsif (!$existing{$ckey}) { - if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') { + $logentry=$1.'; '.$logentry; + if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry}, + $cdom,$cnum) eq 'ok') { # key now belongs to user my $envkey='key.'.$cdom.'_'.$cnum; if (&put('environment',{$envkey => $ckey}) eq 'ok') { @@ -618,6 +675,7 @@ sub assign_access_key { } else { return 'error: Could not assign key, try again later.'; } + } elsif (!$existing{$ckey}) { # the key does not exist return 'error: The key does not exist'; } else { @@ -626,15 +684,43 @@ sub assign_access_key { } } +# ------------------------------------------ put an additional comment on a key + +sub comment_access_key { +# +# a valid key looks like uname:udom#comments +# comments are being appended +# + my ($ckey,$cdom,$cnum,$logentry)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + if ($existing{$ckey}) { + $existing{$ckey}.='; '.$logentry; +# ready to assign + if (&put('accesskeys',{$ckey=>$existing{$ckey}}, + $cdom,$cnum) eq 'ok') { + return 'ok'; + } else { + return 'error: Count not store comment.'; + } + } else { +# the key does not exist + return 'error: The key does not exist'; + } +} + # ------------------------------------------------------ Generate a set of keys sub generate_access_keys { - my ($number,$cdom,$cnum)=@_; + my ($number,$cdom,$cnum,$logentry)=@_; $cdom= $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); - unless (&allowed('ccc',$cdom)) { return 0; } + unless (&allowed('mky',$cdom)) { return 0; } unless (($cdom) && ($cnum)) { return 0; } if ($number>10000) { return 0; } sleep(2); # make sure don't get same seed twice @@ -650,7 +736,11 @@ sub generate_access_keys { if ($existing{$newkey}) { $i--; } else { - if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') { + if (&put('accesskeys', + { $newkey => '# generated '.localtime(). + ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. + '; '.$logentry }, + $cdom,$cnum) eq 'ok') { $total++; } } @@ -671,7 +761,7 @@ sub validate_access_key { $udom=$ENV{'user.name'} unless (defined($udom)); $uname=$ENV{'user.domain'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); - return ($existing{$ckey} eq $uname.':'.$udom); + return ($existing{$ckey}=~/^$uname\:$udom\#/); } # ------------------------------------- Find the section of student in a course @@ -892,9 +982,9 @@ sub repcopy { # ------------------------------------------------ Get server side include body sub ssi_body { - my $filelink=shift; + my ($filelink,%form)=@_; my $output=($filelink=~/^http\:/?&externalssi($filelink): - &ssi($filelink)); + &ssi($filelink,%form)); $output=~s/^.*\]*\>//si; $output=~s/\<\/body\s*\>.*$//si; $output=~ @@ -1149,6 +1239,14 @@ sub countacc { } } +sub linklog { + my ($from,$to)=@_; + $from=&declutter($from); + $to=&declutter($to); + $accesshash{$from.'___'.$to.'___comefrom'}=1; + $accesshash{$to.'___'.$from.'___goto'}=1; +} + sub userrolelog { my ($trole,$username,$domain,$area,$tstart,$tend)=@_; if (($trole=~/^ca/) || ($trole=~/^in/) || @@ -1182,8 +1280,8 @@ sub get_course_adv_roles { } else { $returnhash{$key}=$username.':'.$domain; } - } - return sort %returnhash; + } + return %returnhash; } # ---------------------------------------------------------- Course ID routines @@ -1327,19 +1425,19 @@ sub devalidate { my ($symb,$uname,$udom)=@_; my $cid=$ENV{'request.course.id'}; if ($cid) { -# delete the stored spreadsheets for -# - the student level sheet of this user in course's homespace -# - the assessment level sheet for this resource -# for this user in user's homespace + # delete the stored spreadsheets for + # - the student level sheet of this user in course's homespace + # - the assessment level sheet for this resource + # for this user in user's homespace my $key=$uname.':'.$udom.':'; my $status= &del('nohist_calculatedsheets', - [$key.'studentcalc'], + [$key.'studentcalc:'], $ENV{'course.'.$cid.'.domain'}, $ENV{'course.'.$cid.'.num'}) .' '. &del('nohist_calculatedsheets_'.$cid, - [$key.'assesscalc:'.$symb]); + [$key.'assesscalc:'.$symb],$udom,$uname); unless ($status eq 'ok ok') { &logthis('Could not devalidate spreadsheet '. $uname.' at '.$udom.' for '. @@ -1545,7 +1643,7 @@ sub tmpreset { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } + if (!$symb) { $symb= $ENV{'request.url'}; } } $symb=escape($symb); @@ -1838,14 +1936,14 @@ sub rolesinit { my ($tdummy,$tdomain,$trest)=split(/\//,$area); if ($trole =~ /^cr\//) { my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); - my $homsvr=homeserver($rauthor,$rdomain); + my $homsvr=homeserver($rauthor,$rdomain); if ($hostname{$homsvr} ne '') { - my $roledef= - reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", - $homsvr); - if (($roledef ne 'con_lost') && ($roledef ne '')) { + my ($rdummy,$roledef)= + &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); + + if (($rdummy ne 'con_lost') && ($roledef ne '')) { my ($syspriv,$dompriv,$coursepriv)= - split(/\_/,unescape($roledef)); + split(/\_/,$roledef); if (defined($syspriv)) { $allroles{'cm./'}.=':'.$syspriv; $allroles{$spec.'./'}.=':'.$syspriv; @@ -2423,7 +2521,7 @@ sub is_on_map { sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; - foreach (split('/',$sysrole)) { + foreach (split(':',$sysrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } if ($pr{'cr:s'}=~/$crole\&/) { @@ -2432,7 +2530,7 @@ sub definerole { } } } - foreach (split('/',$domrole)) { + foreach (split(':',$domrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } if ($pr{'cr:d'}=~/$crole\&/) { @@ -2441,7 +2539,7 @@ sub definerole { } } } - foreach (split('/',$courole)) { + foreach (split(':',$courole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } if ($pr{'cr:c'}=~/$crole\&/) { @@ -2550,7 +2648,7 @@ sub plaintext { # ----------------------------------------------------------------- Assign Role sub assignrole { - my ($udom,$uname,$url,$role,$end,$start)=@_; + my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; my $mrole; if ($role =~ /^cr\//) { unless (&allowed('ccr',$url)) { @@ -2563,7 +2661,7 @@ sub assignrole { } else { my $cwosec=$url; $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; - unless (&allowed('c'.$role,$cwosec)) { + unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); @@ -2581,7 +2679,21 @@ sub assignrole { $command.='_0_'.$start; } } +# actually delete + if ($deleteflag) { + if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { +# modify command to delete the role + $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$udom:$uname:$url".'_'."$mrole"; + &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); +# set start and finish to negative values for userrolelog + $start=-1; + $end=-1; + } + } +# send command my $answer=&reply($command,&homeserver($uname,$udom)); +# log new user role if status is ok if ($answer eq 'ok') { &userrolelog($mrole,$uname,$udom,$url,$start,$end); } @@ -2620,7 +2732,7 @@ sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, - $forceid, $desiredhome)=@_; + $forceid, $desiredhome, $email)=@_; $udom=~s/\W//g; $uname=~s/\W//g; &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. @@ -2662,7 +2774,7 @@ sub modifyuser { } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { - return 'error: verify home'; + return 'error: unable verify users home machine.'; } } # End of creation of new user # ---------------------------------------------------------------------- Add ID @@ -2672,7 +2784,8 @@ sub modifyuser { if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) && (!$forceid)) { unless ($uid eq $uidhash{$uname}) { - return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; + return 'error: user id "'.$uid.'" does not match '. + 'current user id "'.$uidhash{$uname}.'".'; } } else { &idput($udom,($uname => $uid)); @@ -2688,10 +2801,17 @@ sub modifyuser { } else { %names = @tmp; } +# +# Make sure to not trash student environment if instructor does not bother +# to supply name and email information +# if ($first) { $names{'firstname'} = $first; } - if ($middle) { $names{'middlename'} = $middle; } + if (defined($middle)) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } - if ($gene) { $names{'generation'} = $gene; } + if (defined($gene)) { $names{'generation'} = $gene; } + if ($email) { $names{'notification'} = $email; + $names{'critnotification'} = $email; } + my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. @@ -2705,7 +2825,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome)=@_; + $end,$start,$forceid,$desiredhome,$email)=@_; my $cid=''; unless ($cid=$ENV{'request.course.id'}) { return 'not_in_class'; @@ -2713,7 +2833,7 @@ sub modifystudent { # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, - $desiredhome); + $desiredhome,$email); unless ($reply eq 'ok') { return $reply; } # This will cause &modify_student_enrollment to get the uid from the # students environment @@ -2831,6 +2951,11 @@ sub createcourse { return 'error: no such course'; } # ----------------------------------------------------------------- Course made +# log existance + &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), + $uhome); + &flushcourselogs(); +# set toplevel url my $topurl=$url; unless ($nonstandard) { # ------------------------------------------ For standard courses, make top url @@ -2859,25 +2984,26 @@ ENDINITMAP # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, - $end,$start); + $end,$start,$deleteflag); } # ----------------------------------------------------------------- Revoke Role sub revokerole { - my ($udom,$uname,$url,$role)=@_; + my ($udom,$uname,$url,$role,$deleteflag)=@_; my $now=time; - return &assignrole($udom,$uname,$url,$role,$now); + return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); } # ---------------------------------------------------------- Revoke Custom Role sub revokecustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; my $now=time; - return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); + return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, + $deleteflag); } # ------------------------------------------------------------ Directory lister @@ -2966,12 +3092,12 @@ sub GetFileTimestamp { $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; my $proname="$studentDomain/$subdir/$studentName"; $proname .= '/'.$filename; - my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName, - $root); - my $fileStat = $dir[0]; + my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, + $studentName, $root); my @stats = split('&', $fileStat); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { - return $stats[9]; + # @stats contains first the filename, then the stat output + return $stats[10]; # so this is 10 instead of 9. } else { return -1; } @@ -3067,16 +3193,42 @@ sub courseresdata { return undef; } -# --------------------------------------------------------- Value of a Variable +# +# EXT resource caching routines +# + +sub clear_EXT_cache_status { + &delenv('cache.EXT.'); +} + +sub EXT_cache_status { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { + # We know already the user has no data + return 1; + } else { + return 0; + } +} +sub EXT_cache_set { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + &appenv($cachename => time); +} + +# --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,)=@_; + my ($varname,$symbparm,$udom,$uname,$usection)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb my $courseid; + my $publicuser; if (!($uname && $udom)) { - (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + (my $cursymb,$courseid,$udom,$uname,$publicuser)= + &Apache::lonxml::whichuser($symbparm); if (!$symbparm) { $symbparm=$cursymb; } } else { $courseid=$ENV{'request.course.id'}; @@ -3099,7 +3251,12 @@ sub EXT { if (defined($Apache::lonhomework::parsing_a_problem)) { return $Apache::lonhomework::history{$qualifierrest}; } else { - my %restored=&restore($symbparm,$courseid,$udom,$uname); + my %restored; + if ($publicuser || $ENV{'request.state'} eq 'construct') { + %restored=&tmprestore($symbparm,$courseid,$udom,$uname); + } else { + %restored=&restore($symbparm,$courseid,$udom,$uname); + } return $restored{$qualifierrest}; } # ----------------------------------------------------------------- user.access @@ -3112,7 +3269,11 @@ sub EXT { ($udom eq $ENV{'user.domain'})) { return $ENV{join('.',('environment',$qualifierrest))}; } else { - my %returnhash=&userenvironment($udom,$uname,$qualifierrest); + my %returnhash; + if (!$publicuser) { + %returnhash=&userenvironment($udom,$uname, + $qualifierrest); + } return $returnhash{$qualifierrest}; } # ----------------------------------------------------------------- user.course @@ -3136,13 +3297,17 @@ sub EXT { return $uname; # ---------------------------------------------------- Any other user namespace } else { - my %reply=&get($space,[$qualifierrest],$udom,$uname); - return $reply{$qualifierrest}; + my %reply; + if (!$publicuser) { + %reply=&get($space,[$qualifierrest],$udom,$uname); + } + return $reply{$qualifierrest}; } } elsif ($realm eq 'query') { # ---------------------------------------------- pull stuff out of query string - &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]); - return $ENV{'form.'.$space}; + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, + [$spacequalifierrest]); + return $ENV{'form.'.$spacequalifierrest}; } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { @@ -3156,7 +3321,7 @@ sub EXT { return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - if ($courseid eq $ENV{'request.course.id'}) { + if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; @@ -3173,7 +3338,11 @@ sub EXT { ($ENV{'user.domain'} eq $udom)) { $section=$ENV{'request.course.sec'}; } else { - $section=&usection($udom,$uname,$courseid); + if (! defined($usection)) { + $section=&usection($udom,$uname,$courseid); + } else { + $section = $usection; + } } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -3185,11 +3354,9 @@ sub EXT { my $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user - #most student don't have any data set, check if there is some data + #most student don\'t have any data set, check if there is some data #every thirty minutes - if (! - (exists($ENV{'cache.studentresdata'}) - && (($ENV{'cache.studentresdata'}+1800) > time))) { + if (! &EXT_cache_status($udom,$uname)) { my %resourcedata=&get('resourcedata', [$courselevelr,$courselevelm,$courselevel], $udom,$uname); @@ -3208,9 +3375,7 @@ sub EXT { $uname." at ".$udom.": ". $tmp.""); } elsif ($tmp=~/error:No such file/) { - $ENV{'cache.studentresdata'}=time; - &appenv(('cache.studentresdata'=> - $ENV{'cache.studentresdata'})); + &EXT_cache_set($udom,$uname); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } @@ -3330,6 +3495,7 @@ sub metadata { my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; + delete($metacache{$uri.':packages'}); while ($token=$parser->get_token) { if ($token->[0] eq 'S') { if (defined($token->[2]->{'package'})) { @@ -3356,16 +3522,20 @@ sub metadata { $value.=' [Part: '.$part.']'; } my $unikey='parameter'.$keyroot.'_'.$name; - if ($subp eq 'default') { $unikey='parameter_0_'.$name; } - $metathesekeys{$unikey}=1; - $metacache{$uri.':'.$unikey.'.part'}=$part; + if ($subp eq 'default') { + $unikey='parameter_0_'.$name; + $metacache{$uri.':'.$unikey.'.part'}='0'; + } else { + $metacache{$uri.':'.$unikey.'.part'}=$part; + $metathesekeys{$unikey}=1; + } unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { $metacache{$uri.':'.$unikey.'.'.$subp}=$value; } if (defined($metacache{$uri.':'.$unikey.'.default'})) { $metacache{$uri.':'.$unikey}= - $metacache{$uri.':'.$unikey.'.default'} - } + $metacache{$uri.':'.$unikey.'.default'}; + } } } } else { @@ -3461,7 +3631,7 @@ sub metadata_generate_part0 { if ($metakey=~/^parameter\_(.*)/) { my $part=$$metacache{$uri.':'.$metakey.'.part'}; my $name=$$metacache{$uri.':'.$metakey.'.name'}; - if (! exists($$metadata{'parameter_0_'.$name})) { + if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { $allnames{$name}=$part; } } @@ -3491,7 +3661,13 @@ sub gettitle { unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } return &metadata($urlsymb,'title'); } - if ($titlecache{$symb}) { return $titlecache{$symb}; } + if ($titlecache{$symb}) { + if (time < ($titlecache{$symb}[1] + 600)) { + return $titlecache{$symb}[0]; + } else { + delete($titlecache{$symb}); + } + } my ($map,$resid,$url)=split(/\_\_\_/,$symb); my $title=''; my %bighash; @@ -3501,8 +3677,9 @@ sub gettitle { $title=$bighash{'title_'.$mapid.'.'.$resid}; untie %bighash; } + $title=~s/\&colon\;/\:/gs; if ($title) { - $titlecache{$symb}=$title; + $titlecache{$symb}=[$title,time]; return $title; } else { return &metadata($urlsymb,'title'); @@ -3674,29 +3851,92 @@ sub numval { $txt=~tr/u-z/0-5/; $txt=~s/\D//g; return int($txt); -} +} + +sub latest_rnd_algorithm_id { + return '64bit'; +} sub rndseed { my ($symb,$courseid,$domain,$username)=@_; + + my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); if (!$symb) { - unless ($symb=&symbread()) { return time; } + unless ($symb=$wsymb) { return time; } + } + if (!$courseid) { $courseid=$wcourseid; } + if (!$domain) { $domain=$wdomain; } + if (!$username) { $username=$wusername } + my $which=$ENV{"course.$courseid.rndseed"}; + my $CODE=$ENV{'scantron.CODE'}; + if (defined($CODE)) { + &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit') { + return &rndseed_64bit($symb,$courseid,$domain,$username); + } + return &rndseed_32bit($symb,$courseid,$domain,$username); +} + +sub rndseed_32bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32C*",$symb) << 27; + my $symbseed=numval($symb) << 22; + my $namechck=unpack("%32C*",$username) << 17; + my $nameseed=numval($username) << 12; + my $domainseed=unpack("%32C*",$domain) << 7; + my $courseseed=unpack("%32C*",$courseid); + my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return $num; + } +} + +sub rndseed_64bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb) << 21; + my $symbseed=numval($symb) << 10; + my $namechck=unpack("%32S*",$username); + + my $nameseed=numval($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 :$num:$symb"); + return "$num1,$num2"; } - if (!$courseid) { $courseid=$ENV{'request.course.id'};} - if (!$domain) {$domain=$ENV{'user.domain'};} - if (!$username) {$username=$ENV{'user.name'};} +} + +sub rndseed_CODE_64bit { + my ($symb,$courseid,$domain,$username)=@_; { - use integer; - my $symbchck=unpack("%32C*",$symb) << 27; - my $symbseed=numval($symb) << 22; - my $namechck=unpack("%32C*",$username) << 17; - my $nameseed=numval($username) << 12; - my $domainseed=unpack("%32C*",$domain) << 7; - my $courseseed=unpack("%32C*",$courseid); - my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; - #uncommenting these lines can break things! - #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num:$symb"); - return $num; + use integer; + my $symbchck=unpack("%32S*",$symb) << 16; + my $symbseed=numval($symb); + my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; + my $courseseed=unpack("%32S*",$courseid); + my $num1=$symbseed+$CODEseed; + my $num2=$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); + return "$num1,$num2"; + } +} + +sub setup_random_from_rndseed { + my ($rndseed)=@_; + if ($rndseed =~/,/) { + my ($num1,$num2)=split(/,/,$rndseed); + &Math::Random::random_set_seed(abs($num1),abs($num2)); + } else { + &Math::Random::random_set_seed_from_phrase($rndseed); } } @@ -3822,6 +4062,7 @@ sub goodbye { &logthis("Starting Shut down"); &flushcourselogs(); &logthis("Shutting down"); + return DONE; } BEGIN { @@ -3859,7 +4100,8 @@ BEGIN { %domain_auth_arg_def = (); if ($fh) { while (<$fh>) { - next if /^\#/; + next if (/^(\#|\s*$)/); +# next if /^\#/; chomp; my ($domain, $domain_description, $def_auth, $def_auth_arg) = split(/:/,$_,4);