--- loncom/lonnet/perl/lonnet.pm 2005/10/27 19:47:39 1.669
+++ loncom/lonnet/perl/lonnet.pm 2005/11/22 02:24:55 1.684
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.669 2005/10/27 19:47:39 raeburn Exp $
+# $Id: lonnet.pm,v 1.684 2005/11/22 02:24:55 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -49,10 +49,11 @@ use Apache::Constants qw(:common :http);
use HTML::LCParser;
use HTML::Parser;
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;
+use Digest::MD5;
+
my $readit;
my $max_connection_retries = 10; # Or some such value.
@@ -166,7 +167,7 @@ sub reply {
unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
- &logthis("<font color=blue>WARNING:".
+ &logthis("<font color=\"blue\">WARNING:".
" $cmd to $server returned $answer</font>");
}
return $answer;
@@ -190,14 +191,14 @@ sub reconlonc {
sleep 5;
if (-e "$peerfile") { return; }
&logthis(
- "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
+ "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
} else {
&logthis(
- "<font color=blue>WARNING:".
+ "<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");
}
} else {
- &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
+ &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}
}
@@ -206,7 +207,7 @@ sub reconlonc {
sub critical {
my ($cmd,$server)=@_;
unless ($hostname{$server}) {
- &logthis("<font color=blue>WARNING:".
+ &logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");
return 'no_such_host';
}
@@ -240,12 +241,12 @@ sub critical {
}
chomp($wcmd);
if ($wcmd eq $cmd) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Connection buffer $dfilename: $cmd</font>");
&logperm("D:$server:$cmd");
return 'con_delayed';
} else {
- &logthis("<font color=red>CRITICAL:"
+ &logthis("<font color=\"red\">CRITICAL:"
." Critical connection failed: $server $cmd</font>");
&logperm("F:$server:$cmd");
return 'con_failed';
@@ -290,7 +291,7 @@ sub appenv {
my %newenv=@_;
foreach (keys %newenv) {
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Attempt to modify environment ".$_." to ".$newenv{$_}
.'</font>');
delete($newenv{$_});
@@ -304,7 +305,7 @@ sub appenv {
return 'error: '.$!;
}
unless (flock($lockfh,LOCK_EX)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
'Could not obtain exclusive lock in appenv: '.$!);
close($lockfh);
return 'error: '.$!;
@@ -349,7 +350,7 @@ sub delenv {
my $delthis=shift;
my %newenv=();
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);
return 'error';
}
@@ -360,7 +361,7 @@ sub delenv {
return 'error';
}
unless (flock($fh,LOCK_SH)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
'Could not obtain shared lock in delenv: '.$!);
close($fh);
return 'error: '.$!;
@@ -374,7 +375,7 @@ sub delenv {
return 'error';
}
unless (flock($fh,LOCK_EX)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
'Could not obtain exclusive lock in delenv: '.$!);
close($fh);
return 'error: '.$!;
@@ -443,15 +444,15 @@ sub overloaderror {
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
- my ($loadpercent,$userloadpercent) = @_;
+ my ($loadpercent,$userloadpercent,$want_server_name) = @_;
my $tryserver;
my $spareserver='';
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
my $lowestserver=$loadpercent > $userloadpercent?
$loadpercent : $userloadpercent;
- foreach $tryserver (keys %spareid) {
- my $loadans=reply('load',$tryserver);
- my $userloadans=reply('userload',$tryserver);
+ foreach $tryserver (keys(%spareid)) {
+ my $loadans=&reply('load',$tryserver);
+ my $userloadans=&reply('userload',$tryserver);
if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
next; #didn't get a number from the server
}
@@ -468,7 +469,11 @@ sub spareserver {
$answer = $userloadans;
}
if (($answer =~ /\d/) && ($answer<$lowestserver)) {
- $spareserver="http://$hostname{$tryserver}";
+ if ($want_server_name) {
+ $spareserver=$tryserver;
+ } else {
+ $spareserver="http://$hostname{$tryserver}";
+ }
$lowestserver=$answer;
}
}
@@ -1060,7 +1065,7 @@ sub repcopy {
if ($response->is_error()) {
unlink($transname);
my $message=$response->status_line;
- &logthis("<font color=blue>WARNING:"
+ &logthis("<font color=\"blue\">WARNING:"
." LWP get: $message: $filename</font>");
return 'unavailable';
} else {
@@ -1070,7 +1075,7 @@ sub repcopy {
if ($mresponse->is_error()) {
unlink($filename.'.meta');
&logthis(
- "<font color=yellow>INFO: No metadata: $filename</font>");
+ "<font color=\"yellow\">INFO: No metadata: $filename</font>");
}
}
rename($transname,$filename);
@@ -1538,7 +1543,7 @@ sub flushcourselogs {
} else {
&logthis('Failed to flush log buffer for '.$crsid);
if (length($courselogs{$crsid})>40000) {
- &logthis("<font color=blue>WARNING: Buffer for ".$crsid.
+ &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
" exceeded maximum size, deleting.</font>");
delete $courselogs{$crsid};
}
@@ -1949,7 +1954,7 @@ sub checkout {
$now.'&'.$ENV{'REMOTE_ADDR'});
my $token=&reply('tmpput:'.$infostr,$lonhost);
if ($token=~/^error\:/) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
return '';
@@ -1965,7 +1970,7 @@ sub checkout {
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';
} else {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
}
@@ -1975,7 +1980,7 @@ sub checkout {
$token)) ne 'ok') {
return '';
} else {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
}
@@ -2570,15 +2575,17 @@ sub rolesinit {
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
my %allroles=();
+ my %allgroups=();
my $now=time;
my $userroles="user.login.time=$now\n";
+ my $group_privs;
if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;
- my ($trole,$tend,$tstart);
+ my ($trole,$tend,$tstart,$group_privs);
if ($role=~/^cr/) {
if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
@@ -2586,6 +2593,10 @@ sub rolesinit {
} else {
$trole=$role;
}
+ } elsif ($role =~ m|^gr/|) {
+ ($trole,$tend,$tstart) = split(/_/,$role);
+ ($trole,$group_privs) = split(/\//,$trole);
+ $group_privs = &unescape($group_privs);
} else {
($trole,$tend,$tstart)=split(/_/,$role);
}
@@ -2597,13 +2608,15 @@ sub rolesinit {
my ($tdummy,$tdomain,$trest)=split(/\//,$area);
if ($trole =~ /^cr\//) {
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+ } elsif ($trole eq 'gr') {
+ &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
} else {
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}
}
}
}
- my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
+ my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);
$userroles.='user.adv='.$adv."\n".
'user.author='.$author."\n";
$env{'user.adv'}=$adv;
@@ -2645,6 +2658,17 @@ sub custom_roleprivs {
}
}
+sub group_roleprivs {
+ my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
+ my $access = 1;
+ my $now = time;
+ if (($tend!=0) && ($tend<$now)) { $access = 0; }
+ if (($tstart!=0) && ($tstart>$now)) { $access=0; }
+ if ($access) {
+ my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);
+ $$allgroups{$course}{$group} .=':'.$group_privs;
+ }
+}
sub standard_roleprivs {
my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
@@ -2665,9 +2689,31 @@ sub standard_roleprivs {
}
sub set_userprivs {
- my ($userroles,$allroles) = @_;
+ my ($userroles,$allroles,$allgroups) = @_;
my $author=0;
my $adv=0;
+ my %grouproles = ();
+ if (keys(%{$allgroups}) > 0) {
+ foreach my $role (keys %{$allroles}) {
+ my ($trole,$area,$sec,$extendedarea);
+ if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
+ $trole = $1;
+ $area = $2;
+ $sec = $3;
+ $extendedarea = $area.$sec;
+ if (exists($$allgroups{$area})) {
+ foreach my $group (keys(%{$$allgroups{$area}})) {
+ my $spec = $trole.'.'.$extendedarea;
+ $grouproles{$spec.'.'.$area.'/'.$group} =
+ $$allgroups{$area}{$group};
+ }
+ }
+ }
+ }
+ }
+ foreach (keys(%grouproles)) {
+ $$allroles{$_} = $grouproles{$_};
+ }
foreach (keys %{$allroles}) {
my %thesepriv=();
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
@@ -3019,8 +3065,6 @@ sub allowed {
my $orguri=$uri;
$uri=&declutter($uri);
-
-
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))
@@ -3067,7 +3111,7 @@ sub allowed {
if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
# uri is the requested domain in this case.
# comparison to 'request.role.domain' shows if the user has selected
- # a role of dc for the domain in question.
+ # a role of dc for the domain in question.
return 'F' if ($uri eq $env{'request.role.domain'});
}
@@ -3098,22 +3142,38 @@ sub allowed {
$thisallowed.=$1;
}
+# Group: uri itself is a group
+ my $groupuri=$uri;
+ $groupuri=~s/^([^\/])/\/$1/;
+ if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}
+ =~/\Q$priv\E\&([^\:]*)/) {
+ $thisallowed.=$1;
+ }
+
# URI is an uploaded document for this course, default permissions don't matter
# not allowing 'edit' access (editupload) to uploaded course docs
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
$thisallowed='';
- my $refuri=$env{'httpref.'.$orguri};
- if ($refuri) {
- if ($refuri =~ m|^/adm/|) {
- $thisallowed='F';
- } else {
- $refuri=&declutter($refuri);
- my ($match) = &is_on_map($refuri);
- if ($match) {
+ my ($match)=&is_on_map($uri);
+ if ($match) {
+ if ($env{'user.priv.'.$env{'request.role'}.'./'}
+ =~/\Q$priv\E\&([^\:]*)/) {
+ $thisallowed.=$1;
+ }
+ } else {
+ my $refuri=$env{'httpref.'.$orguri};
+ if ($refuri) {
+ if ($refuri =~ m|^/adm/|) {
$thisallowed='F';
+ } else {
+ $refuri=&declutter($refuri);
+ my ($match) = &is_on_map($refuri);
+ if ($match) {
+ $thisallowed='F';
+ }
}
- }
- }
+ }
+ }
}
# Full access at system, domain or course-wide level? Exit.
@@ -3281,7 +3341,7 @@ sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {
- &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},
+ &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$env{'request.course.id'});
return '';
@@ -3289,7 +3349,7 @@ sub allowed {
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {
- &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},
+ &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
$env{'request.course.id'});
return '';
@@ -3301,8 +3361,8 @@ sub allowed {
if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$env{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
- &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},
- 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
+ &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
+ 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
return '';
}
}
@@ -3640,11 +3700,102 @@ sub auto_instcode_format {
return $response;
}
+# ------------------------------------------------------- Course Group routines
+
+sub get_coursegroups {
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('coursegroups',$cdom,$cnum,$group));
+}
+
+sub modify_coursegroup {
+ my ($cdom,$cnum,$groupsettings) = @_;
+ return(&put('coursegroups',$groupsettings,$cdom,$cnum));
+}
+
+sub modify_group_roles {
+ my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
+ my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
+ my $role = 'gr/'.&escape($userprivs);
+ my ($uname,$udom) = split(/:/,$user);
+ my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
+ if ($result eq 'ok') {
+ &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
+ }
+
+ return $result;
+}
+
+sub modify_coursegroup_membership {
+ my ($cdom,$cnum,$membership) = @_;
+ my $result = &put('groupmembership',$membership,$cdom,$cnum);
+ return $result;
+}
+
+sub get_active_groups {
+ my ($udom,$uname,$cdom,$cnum) = @_;
+ my $now = time;
+ my %groups = ();
+ foreach my $key (keys(%env)) {
+ if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
+ my ($start,$end) = split(/\./,$env{$key});
+ if (($end!=0) && ($end<$now)) { next; }
+ if (($start!=0) && ($start>$now)) { next; }
+ if ($1 eq $cdom && $2 eq $cnum) {
+ $groups{$3} = $env{$key} ;
+ }
+ }
+ }
+ return %groups;
+}
+
+sub get_group_membership {
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('groupmembership',$cdom,$cnum,$group));
+}
+
+sub get_users_groups {
+ my ($udom,$uname,$courseid) = @_;
+ my $cachetime=1800;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+
+ my $hashid="$udom:$uname:$courseid";
+ my ($result,$cached)=&is_cached_new('getgroups',$hashid);
+ if (defined($cached)) { return $result; }
+
+ my %roleshash = &dump('roles',$udom,$uname,$courseid);
+ my ($tmp) = keys(%roleshash);
+ if ($tmp=~/^error:/) {
+ &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
+ return '';
+ } else {
+ my $grouplist;
+ foreach my $key (keys %roleshash) {
+ if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
+ unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership
+ $grouplist .= $1.':';
+ }
+ }
+ }
+ $grouplist =~ s/:$//;
+ return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
+ }
+}
+
+sub devalidate_getgroups_cache {
+ my ($udom,$uname,$cdom,$cnum)=@_;
+ my $courseid = $cdom.'_'.$cnum;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+ my $hashid="$udom:$uname:$courseid";
+ &devalidate_cache_new('getgroups',$hashid);
+}
+
# ------------------------------------------------------------------ Plain Text
sub plaintext {
my $short=shift;
- return &mt($prp{$short});
+ return &Apache::lonlocal::mt($prp{$short});
}
# ----------------------------------------------------------------- Assign Role
@@ -3662,6 +3813,16 @@ sub assignrole {
return 'refused';
}
$mrole='cr';
+ } elsif ($role =~ /^gr\//) {
+ my $cwogrp=$url;
+ $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ unless (&allowed('mdg',$cwogrp)) {
+ &logthis('Refused group assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+ $env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
+ $mrole='gr';
} else {
my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
@@ -3822,6 +3983,7 @@ sub modifyuser {
}
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
+ &devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.
@@ -3962,7 +4124,9 @@ sub createcourse {
return 'refused';
}
# ------------------------------------------------------------------- Create ID
- my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
+ my $uname=int(1+rand(9)).
+ ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+ substr($$.time,0,5).unpack("H8",pack("I32",time)).
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
# ----------------------------------------------- Make sure that does not exist
my $uhome=&homeserver($uname,$udom,'true');
@@ -4470,7 +4634,7 @@ sub get_userresdata {
}
#error 2 occurs when the .db doesn't exist
if ($tmp!~/error: 2 /) {
- &logthis("<font color=blue>WARNING:".
+ &logthis("<font color=\"blue\">WARNING:".
" Trying to get resource data for ".
$uname." at ".$udom.": ".
$tmp."</font>");
@@ -4624,7 +4788,7 @@ sub EXT {
# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {
if ($qualifier eq 'textremote') {
- if (&mt('textual_remote_display') eq 'on') {
+ if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
return 1;
} else {
return 0;
@@ -4641,7 +4805,8 @@ sub EXT {
return $env{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {
- my $section;
+ my ($section,$group);
+ my @groups = ();
if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
if (!$symbparm) { $symbparm=&symbread(); }
}
@@ -4661,14 +4826,29 @@ sub EXT {
if (($env{'user.name'} eq $uname) &&
($env{'user.domain'} eq $udom)) {
$section=$env{'request.course.sec'};
+ @groups=split(/:/,$env{'request.course.groups'});
+ if (@groups > 0) {
+ @groups = sort(@groups);
+ $group = $groups[0];
+ }
} else {
if (! defined($usection)) {
$section=&getsection($udom,$uname,$courseid);
} else {
$section = $usection;
}
+ my $grouplist = &get_users_groups($udom,$uname,$courseid);
+ if ($grouplist) {
+ @groups = split(/:/,$grouplist);
+ @groups = sort(@groups);
+ $group = $groups[0];
+ }
}
+ my $grplevel=$courseid.'.['.$group.'].'.$spacequalifierrest;
+ my $grplevelr=$courseid.'.['.$group.'].'.$symbparm;
+ my $grplevelm=$courseid.'.['.$group.'].'.$mapparm;
+
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
@@ -4686,8 +4866,17 @@ sub EXT {
if (defined($userreply)) { return $userreply; }
# ------------------------------------------------ second, check some of course
+ my $coursereply;
+ if (defined($group)) {
+ $coursereply = &resdata($env{'course.'.$courseid.'.num'},
+ $env{'course.'.$courseid.'.domain'},
+ 'course',
+ ($grplevelr,$grplevelm,$grplevel,
+ $courselevelr));
+ if (defined($coursereply)) { return $coursereply; }
+ }
- my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
+ $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},
'course',
($seclevelr,$seclevelm,$seclevel,
@@ -5365,8 +5554,37 @@ sub numval3 {
return $total;
}
+sub digest {
+ my ($data)=@_;
+ my $digest=&Digest::MD5::md5($data);
+ my ($a,$b,$c,$d)=unpack("iiii",$digest);
+ my ($e,$f);
+ {
+ use integer;
+ $e=($a+$b);
+ $f=($c+$d);
+ if ($_64bit) {
+ $e=(($e<<32)>>32);
+ $f=(($f<<32)>>32);
+ }
+ }
+ if (wantarray) {
+ return ($e,$f);
+ } else {
+ my $g;
+ {
+ use integer;
+ $g=($e+$f);
+ if ($_64bit) {
+ $g=(($g<<32)>>32);
+ }
+ }
+ return $g;
+ }
+}
+
sub latest_rnd_algorithm_id {
- return '64bit4';
+ return '64bit5';
}
sub get_rand_alg {
@@ -5406,11 +5624,15 @@ sub rndseed {
if (!$username) { $username=$wusername }
my $which=&get_rand_alg();
if (defined(&getCODE())) {
- if ($which eq '64bit4') {
+ if ($which eq '64bit5') {
+ return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
+ } elsif ($which eq '64bit4') {
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
} else {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
}
+ } elsif ($which eq '64bit5') {
+ return &rndseed_64bit5($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit4') {
return &rndseed_64bit4($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit3') {
@@ -5533,6 +5755,12 @@ sub rndseed_64bit4 {
}
}
+sub rndseed_64bit5 {
+ my ($symb,$courseid,$domain,$username)=@_;
+ my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
+ return "$num1:$num2";
+}
+
sub rndseed_CODE_64bit {
my ($symb,$courseid,$domain,$username)=@_;
{
@@ -5571,6 +5799,13 @@ sub rndseed_CODE_64bit4 {
}
}
+sub rndseed_CODE_64bit5 {
+ my ($symb,$courseid,$domain,$username)=@_;
+ my $code = &getCODE();
+ my ($num1,$num2)=&digest("$symb,$courseid,$code");
+ return "$num1:$num2";
+}
+
sub setup_random_from_rndseed {
my ($rndseed)=@_;
if ($rndseed =~/([,:])/) {
@@ -5909,13 +6144,6 @@ sub thaw_unescape {
return &unescape($value);
}
-sub mod_perl_version {
- return 1;
- if (defined($perlvar{'MODPERL2'})) {
- return 2;
- }
-}
-
sub correct_line_ends {
my ($result)=@_;
$$result =~s/\r\n/\n/mg;
@@ -6114,7 +6342,7 @@ $processmarker='_'.time.'_'.$perlvar{'lo
$dumpcount=0;
&logtouch();
-&logthis('<font color=yellow>INFO: Read configuration</font>');
+&logthis('<font color="yellow">INFO: Read configuration</font>');
$readit=1;
{
use integer;