--- loncom/lonnet/perl/lonnet.pm 2003/03/18 07:26:49 1.341 +++ loncom/lonnet/perl/lonnet.pm 2003/05/08 21:50:54 1.370 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.341 2003/03/18 07:26:49 www Exp $ +# $Id: lonnet.pm,v 1.370 2003/05/08 21:50:54 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -74,8 +74,8 @@ use HTTP::Headers; use vars qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom %libserv %pr %prp %metacache %packagetab %titlecache - %courselogs %accesshash $processmarker $dumpcount - %coursedombuf %coursehombuf %courseresdatacache + %courselogs %accesshash %userrolehash $processmarker $dumpcount + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); use IO::Socket; use GDBM_File; @@ -347,6 +347,29 @@ 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) { $num_users++; } + } + closedir(LONIDS); + } + my $userloadpercent=0; + my $maxuserload=$perlvar{'lonUserLoadLim'}; + if ($maxuserload) { + $userloadpercent=100*$num_users/$maxuserload; + } + return $userloadpercent; +} + # ------------------------------------------ Fight off request when overloaded sub overloaderror { @@ -373,17 +396,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; } @@ -588,6 +617,132 @@ sub idput { } } +# --------------------------------------------------- Assign a key to a student + +sub assign_access_key { +# +# 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= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$ENV{'user.name'} unless (defined($udom)); + $uname=$ENV{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + 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 + $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') { + &appenv('environment.'.$envkey => $ckey); + return 'ok'; + } else { + return + 'error: Count not permanently assign key, will need to be re-entered later.'; + } + } 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 { +# the key is somebody else's + return 'error: The key is already in use'; + } +} + +# ------------------------------------------ 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,$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('mky',$cdom)) { return 0; } + unless (($cdom) && ($cnum)) { return 0; } + if ($number>10000) { return 0; } + sleep(2); # make sure don't get same seed twice + srand(time()^($$+($$<<15))); # from "Programming Perl" + my $total=0; + for (my $i=1;$i<=$number;$i++) { + my $newkey=sprintf("%lx",int(100000*rand)).'-'. + sprintf("%lx",int(100000*rand)).'-'. + sprintf("%lx",int(100000*rand)); + $newkey=~s/1/g/g; # folks mix up 1 and l + $newkey=~s/0/h/g; # and also 0 and O + my %existing=&get('accesskeys',[$newkey],$cdom,$cnum); + if ($existing{$newkey}) { + $i--; + } else { + if (&put('accesskeys', + { $newkey => '# generated '.localtime(). + ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. + '; '.$logentry }, + $cdom,$cnum) eq 'ok') { + $total++; + } + } + } + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + 'Generated '.$total.' keys for '.$cnum.' at '.$cdom); + return $total; +} + +# ------------------------------------------------------- Validate an accesskey + +sub validate_access_key { + my ($ckey,$cdom,$cnum,$udom,$uname)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$ENV{'user.name'} unless (defined($udom)); + $uname=$ENV{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + return ($existing{$ckey}=~/^$uname\:$udom\#/); +} + # ------------------------------------- Find the section of student in a course sub getsection { @@ -941,12 +1096,24 @@ sub log { } # ------------------------------------------------------------------ Course Log +# +# This routine flushes several buffers of non-mission-critical nature +# sub flushcourselogs { - &logthis('Flushing course log buffers'); + &logthis('Flushing log buffers'); +# +# course logs +# This is a log of all transactions in a course, which can be used +# for data mining purposes +# +# It also collects the courseid database, which lists last transaction +# times and course titles for all courseids +# + my %courseidbuffer=(); foreach (keys %courselogs) { my $crsid=$_; - if (&reply('log:'.$coursedombuf{$crsid}.':'. + if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { delete $courselogs{$crsid}; @@ -957,9 +1124,26 @@ sub flushcourselogs { " exceeded maximum size, deleting."); delete $courselogs{$crsid}; } - } + } + if ($courseidbuffer{$coursehombuf{$crsid}}) { + $courseidbuffer{$coursehombuf{$crsid}}.='&'. + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + } else { + $courseidbuffer{$coursehombuf{$crsid}}= + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + } } - &logthis('Flushing access logs'); +# +# Write course id database (reverse lookup) to homeserver of courses +# Is used in pickcourse +# + foreach (keys %courseidbuffer) { + &courseidput($hostdom{$_},$courseidbuffer{$_},$_); + } +# +# File accesses +# Writes to the dynamic metadata of resources to get hit counts, etc. +# foreach (keys %accesshash) { my $entry=$_; $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; @@ -968,6 +1152,20 @@ sub flushcourselogs { delete $accesshash{$entry}; } } +# +# Roles +# Reverse lookup of user roles for course faculty/staff and co-authorship +# + foreach (keys %userrolehash) { + my $entry=$_; + my ($role,$uname,$udom,$runame,$rudom,$rsec)= + split(/\:/,$entry); + if (&Apache::lonnet::put('nohist_userroles', + { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} }, + $rudom,$runame) eq 'ok') { + delete $userrolehash{$entry}; + } + } $dumpcount++; } @@ -976,10 +1174,13 @@ sub courselog { $what=time.':'.$what; unless ($ENV{'request.course.id'}) { return ''; } $coursedombuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + $coursenumbuf{$ENV{'request.course.id'}}= $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; $coursehombuf{$ENV{'request.course.id'}}= $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + $coursedescrbuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; if (defined $courselogs{$ENV{'request.course.id'}}) { $courselogs{$ENV{'request.course.id'}}.='&'.$what; } else { @@ -1016,7 +1217,83 @@ sub countacc { $accesshash{$key}=1; } } - + +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/) || + ($trole=~/^cc/) || ($trole=~/^ep/) || + ($trole=~/^cr/)) { + my (undef,$rudom,$runame,$rsec)=split(/\//,$area); + $userrolehash + {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} + =$tend.':'.$tstart; + } +} + +sub get_course_adv_roles { + my $cid=shift; + $cid=$ENV{'request.course.id'} unless (defined($cid)); + my %coursehash=&coursedescription($cid); + my %returnhash=(); + my %dumphash= + &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); + my $now=time; + foreach (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + if (($tstart) && ($tstart<0)) { next; } + if (($tend) && ($tend<$now)) { next; } + if (($tstart) && ($now<$tstart)) { next; } + my ($role,$username,$domain,$section)=split(/\:/,$_); + my $key=&plaintext($role); + if ($section) { $key.=' (Sec/Grp '.$section.')'; } + if ($returnhash{$key}) { + $returnhash{$key}.=','.$username.':'.$domain; + } else { + $returnhash{$key}=$username.':'.$domain; + } + } + return sort %returnhash; +} + +# ---------------------------------------------------------- Course ID routines +# Deal with domain's nohist_courseid.db files +# + +sub courseidput { + my ($domain,$what,$coursehome)=@_; + return &reply('courseidput:'.$domain.':'.$what,$coursehome); +} + +sub courseiddump { + my ($domfilter,$descfilter,$sincefilter)=@_; + my %returnhash=(); + unless ($domfilter) { $domfilter=''; } + foreach my $tryserver (keys %libserv) { + if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + foreach ( + split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + $sincefilter.':'.&escape($descfilter), + $tryserver))) { + my ($key,$value)=split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)}=&unescape($value); + } + } + + } + } + return %returnhash; +} + +# # ----------------------------------------------------------- Check out an item sub checkout { @@ -1621,6 +1898,8 @@ sub rolesinit { my ($trole,$tend,$tstart)=split(/_/,$role); $userroles.='user.role.'.$trole.'.'.$area.'='. $tstart.'.'.$tend."\n"; +# log the associated role with the area + &userrolelog($trole,$username,$domain,$area,$tstart,$tend); if ($tend!=0) { if ($tend<$now) { $trole=''; @@ -1632,42 +1911,54 @@ sub rolesinit { } } if (($area ne '') && ($trole ne '')) { - my $spec=$trole.'.'.$area; - my ($tdummy,$tdomain,$trest)=split(/\//,$area); - if ($trole =~ /^cr\//) { - my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); - 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 ($syspriv,$dompriv,$coursepriv)= - split(/\_/,unescape($roledef)); - $allroles{'cm./'}.=':'.$syspriv; - $allroles{$spec.'./'}.=':'.$syspriv; - if ($tdomain ne '') { - $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; - $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; - if ($trest ne '') { - $allroles{'cm.'.$area}.=':'.$coursepriv; - $allroles{$spec.'.'.$area}.=':'.$coursepriv; - } - } - } - } - } else { - $allroles{'cm./'}.=':'.$pr{$trole.':s'}; - $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; - if ($tdomain ne '') { - $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; - $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; - if ($trest ne '') { - $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; - $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; - } - } - } + my $spec=$trole.'.'.$area; + my ($tdummy,$tdomain,$trest)=split(/\//,$area); + if ($trole =~ /^cr\//) { + my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); + 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 ($syspriv,$dompriv,$coursepriv)= + split(/\_/,unescape($roledef)); + if (defined($syspriv)) { + $allroles{'cm./'}.=':'.$syspriv; + $allroles{$spec.'./'}.=':'.$syspriv; + } + if ($tdomain ne '') { + if (defined($dompriv)) { + $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; + $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; + } + if ($trest ne '') { + if (defined($coursepriv)) { + $allroles{'cm.'.$area}.=':'.$coursepriv; + $allroles{$spec.'.'.$area}.=':'.$coursepriv; + } + } + } + } + } + } else { + if (defined($pr{$trole.':s'})) { + $allroles{'cm./'}.=':'.$pr{$trole.':s'}; + $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; + } + if ($tdomain ne '') { + if (defined($pr{$trole.':d'})) { + $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; + $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; + } + if ($trest ne '') { + if (defined($pr{$trole.':c'})) { + $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; + $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; + } + } + } + } } } } @@ -1874,10 +2165,29 @@ sub eget { sub customaccess { my ($priv,$uri)=@_; + my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); + $urealm=~s/^\W//; + my ($udom,$ucrs,$usec)=split(/\//,$urealm); my $access=0; foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { - my ($effect,$realm,$content)=split(/\:/,$_); - &logthis('testing '.$effect.' '.$realm.' '.$content); + my ($effect,$realm,$role)=split(/\:/,$_); + if ($role) { + if ($role ne $urole) { next; } + } + foreach (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$_); + if ($tdom) { + if ($tdom ne $udom) { next; } + } + if ($tcrs) { + if ($tcrs ne $ucrs) { next; } + } + if ($tsec) { + if ($tsec ne $usec) { next; } + } + $access=($effect eq 'allow'); + last; + } } return $access; } @@ -2317,7 +2627,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)) { @@ -2348,7 +2658,24 @@ sub assignrole { $command.='_0_'.$start; } } - return &reply($command,&homeserver($uname,$udom)); +# actually delete + if ($deleteflag) { + if (&allowed('dro',$udom)) { +# modify command to delete the role + $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$udom:$uname:$url".'_'."$mrole"; +# 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); + } + return $answer; } # -------------------------------------------------- Modify user authentication @@ -2594,6 +2921,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 @@ -2622,25 +2954,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 @@ -2838,8 +3171,10 @@ sub EXT { 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(); if (!$symbparm) { $symbparm=$cursymb; } } else { $courseid=$ENV{'request.course.id'}; @@ -2862,7 +3197,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 @@ -2875,7 +3215,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 @@ -2899,8 +3243,11 @@ 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 @@ -2919,7 +3266,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; @@ -3093,6 +3440,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'})) { @@ -3119,16 +3467,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 { @@ -3224,7 +3576,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; } } @@ -3264,6 +3616,7 @@ sub gettitle { $title=$bighash{'title_'.$mapid.'.'.$resid}; untie %bighash; } + $title=~s/\&colon\;/\:/gs; if ($title) { $titlecache{$symb}=$title; return $title; @@ -3437,29 +3790,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=$ENV{'request.course.id'};} - if (!$domain) {$domain=$ENV{'user.domain'};} - if (!$username) {$username=$ENV{'user.name'};} + 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"; + } +} + +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); } } @@ -3585,6 +4001,7 @@ sub goodbye { &logthis("Starting Shut down"); &flushcourselogs(); &logthis("Shutting down"); + return DONE; } BEGIN {