--- loncom/lonnet/perl/lonnet.pm 2001/01/05 20:45:09 1.87
+++ loncom/lonnet/perl/lonnet.pm 2001/07/26 17:22:19 1.129
@@ -3,6 +3,9 @@
#
# Functions for use by content handlers:
#
+# metadata_query(sql-query-string,custom-metadata-regex) :
+# returns file handle of where sql and
+# regex results will be stored for query
# plaintext(short) : plain text explanation of short term
# fileembstyle(ext) : embed style in page for file extension
# filedescription(ext) : descriptor text for file extension
@@ -13,7 +16,7 @@
# 1: user needs to choose course
# 2: browse allowed
# definerole(rolename,sys,dom,cou) : define a custom role rolename
-# set priviledges in format of lonTabs/roles.tab for
+# set privileges in format of lonTabs/roles.tab for
# system, domain and course level,
# assignrole(udom,uname,url,role,end,start) : give a role to a user for the
# level given by url. Optional start and end dates
@@ -25,15 +28,27 @@
# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
# appenv(hash) : adds hash to session environment
# delenv(varname) : deletes all environment entries starting with varname
-# store(hash) : stores hash permanently for this url
-# cstore(hash) : critical store
-# restore : returns hash for this url
+# store(hashref,symb,courseid,udom,uname)
+# : stores hash permanently for this url
+# hashref needs to be given, and should be a \%hashname
+# the remaining args aren't required and if they aren't
+# passed or are '' they will be derived from the ENV
+# cstore(hashref,symb,courseid,udom,uname)
+# : same as store but uses the critical interface to
+# guarentee a store
+# restore(symb,courseid,udom,uname)
+# : returns hash for this symb, all args are optional
+# if they aren't given they will be derived from the
+# current enviroment
# eget(namesp,array) : returns hash with keys from array filled in from namesp
# get(namesp,array) : returns hash with keys from array filled in from namesp
# del(namesp,array) : deletes keys out of array from namesp
# put(namesp,hash) : stores hash in namesp
# cput(namesp,hash) : critical put
-# dump(namesp) : dumps the complete namespace into a hash
+# dump(namesp,udom,uname) : dumps the complete namespace into a hash
+# if supplied uses udom as the domain and uname
+# as the username for the dump (supply a courseid
+# for the uname if you want a course database)
# ssi(url,hash) : does a complete request cycle on url to localhost, posts
# hash
# coursedescription(id) : returns and caches course description for id
@@ -49,7 +64,7 @@
# receipt() : returns a receipt to be given out to users
# getfile(filename) : returns the contents of filename, or a -1 if it can't
# be found, replicates and subscribes to the file
-# filelocation(dir,file) : returns a farily clean absolute reference to file
+# filelocation(dir,file) : returns a fairly clean absolute reference to file
# from the directory dir
# hreflocation(dir,file) : same as filelocation, but for hrefs
# log(domain,user,home,msg) : write to permanent log for user
@@ -83,7 +98,18 @@
# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
# 05/01/01 Guy Albertelli
-# 05/01 Gerd Kortemeyer
+# 05/01,06/01,09/01 Gerd Kortemeyer
+# 09/01 Guy Albertelli
+# 09/01,10/01,11/01 Gerd Kortemeyer
+# 02/27/01 Scott Harrison
+# 3/2 Gerd Kortemeyer
+# 3/15,3/19 Scott Harrison
+# 3/19,3/20 Gerd Kortemeyer
+# 3/22,3/27,4/2,4/16,4/17 Scott Harrison
+# 5/26,5/28 Gerd Kortemeyer
+# 5/30 H. K. Ng
+# 6/1 Gerd Kortemeyer
+#
package Apache::lonnet;
@@ -97,6 +123,7 @@ use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::TokeParser;
+use Fcntl qw(:flock);
# --------------------------------------------------------------------- Logging
@@ -179,6 +206,11 @@ sub reconlonc {
sub critical {
my ($cmd,$server)=@_;
+ unless ($hostname{$server}) {
+ &logthis("WARNING:".
+ " Critical message to unknown server ($server)");
+ return 'no_such_host';
+ }
my $answer=reply($cmd,$server);
if ($answer eq 'con_lost') {
my $pingreply=reply('ping',$server);
@@ -237,13 +269,26 @@ sub appenv {
$ENV{$_}=$newenv{$_};
}
} keys %newenv;
+
+ my $lockfh;
+ unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
+ return 'error: '.$!;
+ }
+ unless (flock($lockfh,LOCK_EX)) {
+ &logthis("WARNING: ".
+ 'Could not obtain exclusive lock in appenv: '.$!);
+ $lockfh->close();
+ return 'error: '.$!;
+ }
+
my @oldenv;
{
my $fh;
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
- return 'error';
+ return 'error: '.$!;
}
@oldenv=<$fh>;
+ $fh->close();
}
for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);
@@ -260,12 +305,13 @@ sub appenv {
return 'error';
}
my $newname;
- flock($fh,'LOCK_EX');
foreach $newname (keys %newenv) {
print $fh "$newname=$newenv{$newname}\n";
}
$fh->close();
}
+
+ $lockfh->close();
return 'ok';
}
# ----------------------------------------------------- Delete from Environment
@@ -284,14 +330,26 @@ sub delenv {
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
return 'error';
}
+ unless (flock($fh,LOCK_SH)) {
+ &logthis("WARNING: ".
+ 'Could not obtain shared lock in delenv: '.$!);
+ $fh->close();
+ return 'error: '.$!;
+ }
@oldenv=<$fh>;
+ $fh->close();
}
{
my $fh;
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
return 'error';
}
- flock($fh,'LOCK_EX');
+ unless (flock($fh,LOCK_EX)) {
+ &logthis("WARNING: ".
+ 'Could not obtain exclusive lock in delenv: '.$!);
+ $fh->close();
+ return 'error: '.$!;
+ }
map {
unless ($_=~/^$delthis/) { print $fh $_; }
} @oldenv;
@@ -588,52 +646,126 @@ sub log {
return critical("log:$dom:$nam:$what",$hom);
}
+# --------------------------------------------- Set Expire Date for Spreadsheet
+
+sub expirespread {
+ my ($uname,$udom,$stype,$usymb)=@_;
+ my $cid=$ENV{'request.course.id'};
+ if ($cid) {
+ my $now=time;
+ my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
+ return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
+ $ENV{'course.'.$cid.'.num'}.
+ ':nohist_expirationdates:'.
+ &escape($key).'='.$now,
+ $ENV{'course.'.$cid.'.home'})
+ }
+ return 'ok';
+}
+
+# ----------------------------------------------------- Devalidate Spreadsheets
+
+sub devalidate {
+ my $symb=shift;
+ my $cid=$ENV{'request.course.id'};
+ if ($cid) {
+ my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
+ my $status=
+ &reply('del:'.$ENV{'course.'.$cid.'.domain'}.':'.
+ $ENV{'course.'.$cid.'.num'}.
+ ':nohist_calculatedsheets:'.
+ &escape($key.'studentcalc:'),
+ $ENV{'course.'.$cid.'.home'})
+ .' '.
+ &reply('del:'.$ENV{'user.domain'}.':'.
+ $ENV{'user.name'}.
+ ':nohist_calculatedsheets_'.$cid.':'.
+ &escape($key.'assesscalc:'.$symb),
+ $ENV{'user.home'});
+ unless ($status eq 'ok ok') {
+ &logthis('Could not devalidate spreadsheet '.
+ $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
+ $symb.': '.$status);
+ }
+ }
+}
+
# ----------------------------------------------------------------------- Store
sub store {
- my %storehash=@_;
- my $symb;
- unless ($symb=escape(&symbread())) { return ''; }
- my $namespace;
- unless ($namespace=$ENV{'request.course.id'}) { return ''; }
+ my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+ my $home='';
+
+ if ($stuname) {
+ $home=&homeserver($stuname,$domain);
+ }
+
+ if (!$symb) { unless ($symb=&symbread()) { return ''; } }
+
+ &devalidate($symb);
+
+ $symb=escape($symb);
+ if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ if (!$home) { $home=$ENV{'user.home'}; }
my $namevalue='';
map {
- $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
- } keys %storehash;
+ $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
+ } keys %$storehash;
$namevalue=~s/\&$//;
- return reply(
- "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
- "$ENV{'user.home'}");
+ return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
}
# -------------------------------------------------------------- Critical Store
sub cstore {
- my %storehash=@_;
- my $symb;
- unless ($symb=escape(&symbread())) { return ''; }
- my $namespace;
- unless ($namespace=$ENV{'request.course.id'}) { return ''; }
+ my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+ my $home='';
+
+ if ($stuname) {
+ $home=&homeserver($stuname,$domain);
+ }
+
+ if (!$symb) { unless ($symb=&symbread()) { return ''; } }
+
+ &devalidate($symb);
+
+ $symb=escape($symb);
+ if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ if (!$home) { $home=$ENV{'user.home'}; }
+
my $namevalue='';
map {
- $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
- } keys %storehash;
+ $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
+ } keys %$storehash;
$namevalue=~s/\&$//;
- return critical(
- "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
- "$ENV{'user.home'}");
+ return critical("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
}
# --------------------------------------------------------------------- Restore
sub restore {
- my $symb;
- unless ($symb=escape(&symbread())) { return ''; }
- my $namespace;
- unless ($namespace=$ENV{'request.course.id'}) { return ''; }
- my $answer=reply(
- "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb",
- "$ENV{'user.home'}");
+ my ($symb,$namespace,$domain,$stuname) = @_;
+ my $home='';
+
+ if ($stuname) {
+ $home=&homeserver($stuname,$domain);
+ }
+
+ if (!$symb) {
+ unless ($symb=escape(&symbread())) { return ''; }
+ } else {
+ $symb=&escape($symb);
+ }
+ if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ if (!$home) { $home=$ENV{'user.home'}; }
+ my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
+
my %returnhash=();
map {
my ($name,$value)=split(/\=/,$_);
@@ -655,23 +787,18 @@ sub coursedescription {
$courseid=~s/^\///;
$courseid=~s/\_/\//g;
my ($cdomain,$cnum)=split(/\//,$courseid);
- my $chome=homeserver($cnum,$cdomain);
+ my $chome=&homeserver($cnum,$cdomain);
if ($chome ne 'no_host') {
- my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
- if ($rep ne 'con_lost') {
- my $normalid=$courseid;
- $normalid=~s/\//\_/g;
+ my %returnhash=&dump('environment',$cdomain,$cnum);
+ if (!exists($returnhash{'con_lost'})) {
+ my $normalid=$cdomain.'_'.$cnum;
my %envhash=();
- my %returnhash=('home' => $chome,
- 'domain' => $cdomain,
- 'num' => $cnum);
- map {
- my ($name,$value)=split(/\=/,$_);
- $name=&unescape($name);
- $value=&unescape($value);
- $returnhash{$name}=$value;
+ $returnhash{'home'}= $chome;
+ $returnhash{'domain'} = $cdomain;
+ $returnhash{'num'} = $cnum;
+ while (my ($name,$value) = each %ENV) {
$envhash{'course.'.$normalid.'.'.$name}=$value;
- } split(/\&/,$rep);
+ }
$returnhash{'url'}='/res/'.declutter($returnhash{'url'});
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
@@ -686,7 +813,7 @@ sub coursedescription {
return ();
}
-# -------------------------------------------------------- Get user priviledges
+# -------------------------------------------------------- Get user privileges
sub rolesinit {
my ($domain,$username,$authhost)=@_;
@@ -756,16 +883,20 @@ sub rolesinit {
}
}
} split(/&/,$rolesdump);
+ my $adv=0;
+ my $author=0;
map {
%thesepriv=();
+ if ($_!~/^st/) { $adv=1; }
+ if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
map {
if ($_ ne '') {
- my ($priviledge,$restrictions)=split(/&/,$_);
+ my ($privilege,$restrictions)=split(/&/,$_);
if ($restrictions eq '') {
- $thesepriv{$priviledge}='F';
+ $thesepriv{$privilege}='F';
} else {
- if ($thesepriv{$priviledge} ne 'F') {
- $thesepriv{$priviledge}.=$restrictions;
+ if ($thesepriv{$privilege} ne 'F') {
+ $thesepriv{$privilege}.=$restrictions;
}
}
}
@@ -774,6 +905,9 @@ sub rolesinit {
map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
$userroles.='user.priv.'.$_.'='.$thesestr."\n";
} keys %allroles;
+ $userroles.='user.adv='.$adv."\n".
+ 'user.author='.$author."\n";
+ $ENV{'user.adv'}=$adv;
}
return $userroles;
}
@@ -815,9 +949,11 @@ sub del {
# -------------------------------------------------------------- dump interface
sub dump {
- my $namespace=shift;
- my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
- $ENV{'user.home'});
+ my ($namespace,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
map {
@@ -875,7 +1011,7 @@ sub eget {
return %returnhash;
}
-# ------------------------------------------------- Check for a user priviledge
+# ------------------------------------------------- Check for a user privilege
sub allowed {
my ($priv,$uri)=@_;
@@ -926,7 +1062,7 @@ sub allowed {
return $thisallowed;
}
#
-# Gathered so far: system, domain and course wide priviledges
+# Gathered so far: system, domain and course wide privileges
#
# Course: See if uri or referer is an individual resource that is part of
# the course
@@ -977,7 +1113,7 @@ sub allowed {
}
#
-# Gathered now: all priviledges that could apply, and condition number
+# Gathered now: all privileges that could apply, and condition number
#
#
# Full or no access?
@@ -1009,6 +1145,7 @@ sub allowed {
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
my $courseid=$2;
my $roleid=$1.'.'.$2;
+ $courseid=~s/^\///;
my $expiretime=600;
if ($ENV{'request.role'} eq $roleid) {
$expiretime=120;
@@ -1146,6 +1283,27 @@ sub definerole {
}
}
+# ---------------- Make a metadata query against the network of library servers
+
+sub metadata_query {
+ my ($query,$custom,$customshow)=@_;
+ # need to put in a library server loop here and return a hash
+ my %rhash;
+ for my $server (keys %libserv) {
+ unless ($custom or $customshow) {
+ my $reply=&reply("querysend:".&escape($query),$server);
+ $rhash{$server}=$reply;
+ }
+ else {
+ my $reply=&reply("querysend:".&escape($query).':'.
+ &escape($custom).':'.&escape($customshow),
+ $server);
+ $rhash{$server}=$reply;
+ }
+ }
+ return \%rhash;
+}
+
# ------------------------------------------------------------------ Plain Text
sub plaintext {
@@ -1173,12 +1331,22 @@ sub assignrole {
my ($udom,$uname,$url,$role,$end,$start)=@_;
my $mrole;
if ($role =~ /^cr\//) {
- unless (&allowed('ccr',$url)) { return 'refused'; }
+ unless (&allowed('ccr',$url)) {
+ &logthis('Refused custom assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+ $ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ return 'refused';
+ }
$mrole='cr';
} else {
my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
- unless (&allowed('c'.$role,$cwosec)) { return 'refused'; }
+ unless (&allowed('c'.$role,$cwosec)) {
+ &logthis('Refused assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+ $ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ return 'refused';
+ }
$mrole=$role;
}
my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
@@ -1509,7 +1677,7 @@ sub EXT {
if ($realm eq 'user') {
# --------------------------------------------------------------- user.resource
if ($space eq 'resource') {
- my %restored=&restore;
+ my %restored=&restore();
return $restored{$qualifierrest};
# ----------------------------------------------------------------- user.access
} elsif ($space eq 'access') {
@@ -1550,69 +1718,79 @@ sub EXT {
}
} elsif ($realm eq 'course') {
# ---------------------------------------------------------- course.description
- my $section='';
- if ($ENV{'request.course.sec'}) {
- $section='_'.$ENV{'request.course.sec'};
- }
- return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'.
+ return $ENV{'course.'.$ENV{'request.course.id'}.'.'.
$spacequalifierrest};
} elsif ($realm eq 'resource') {
- if ($ENV{'request.course.id'}) {
+ if ($ENV{'request.course.id'}) {
# ----------------------------------------------------- Cascading lookup scheme
- my $symbp=&symbread();
- my $mapp=(split(/\_\_\_/,$symbp))[0];
+ my $symbp=&symbread();
+ my $mapp=(split(/\_\_\_/,$symbp))[0];
- my $symbparm=$symbp.'.'.$spacequalifierrest;
- my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
+ my $symbparm=$symbp.'.'.$spacequalifierrest;
+ my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
- my $seclevel=
+ my $seclevel=
$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$spacequalifierrest;
- my $seclevelr=
+ my $seclevelr=
$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$symbparm;
- my $seclevelm=
+ my $seclevelm=
$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$mapparm;
- my $courselevel=
+ my $courselevel=
$ENV{'request.course.id'}.'.'.$spacequalifierrest;
- my $courselevelr=
+ my $courselevelr=
$ENV{'request.course.id'}.'.'.$symbparm;
- my $courselevelm=
+ my $courselevelm=
$ENV{'request.course.id'}.'.'.$mapparm;
-
# ----------------------------------------------------------- first, check user
- my %resourcedata=get('resourcedata',
+ my %resourcedata=get('resourcedata',
($courselevelr,$courselevelm,$courselevel));
- if ($resourcedata{$courselevelr}!~/^error\:/) {
+ if (($resourcedata{$courselevelr}!~/^error\:/) &&
+ ($resourcedata{$courselevelr}!~/^con_lost/)) {
- if ($resourcedata{$courselevelr}) {
- return $resourcedata{$courselevelr}; }
- if ($resourcedata{$courselevelm}) {
- return $resourcedata{$courselevelm}; }
- if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
+ if ($resourcedata{$courselevelr}) {
+ return $resourcedata{$courselevelr}; }
+ if ($resourcedata{$courselevelm}) {
+ return $resourcedata{$courselevelm}; }
+ if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
+ } else {
+ if ($resourcedata{$courselevelr}!~/No such file/) {
+ &logthis("WARNING:".
+ " Trying to get resource data for ".$ENV{'user.name'}." at "
+ .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
+ "");
+ }
}
+
# -------------------------------------------------------- second, check course
- my $section='';
- if ($ENV{'request.course.sec'}) {
- $section='_'.$ENV{'request.course.sec'};
- }
+
my $reply=&reply('get:'.
- $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.
- $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
+ $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
+ $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
':resourcedata:'.
&escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
&escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
- $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
+ $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
if ($reply!~/^error\:/) {
map {
if ($_) { return &unescape($_); }
} split(/\&/,$reply);
}
-
+ if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
+ &logthis("WARNING:".
+ " Getting ".$reply." asking for ".$varname." for ".
+ $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
+ ' at '.
+ $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
+ ' from '.
+ $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
+ "");
+ }
# ------------------------------------------------------ third, check map parms
my %parmhash=();
my $thisparm='';
@@ -1636,7 +1814,7 @@ sub EXT {
# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment
- return $ENV{$spacequalifierrest};
+ return $ENV{'environment.'.$spacequalifierrest};
} elsif ($realm eq 'system') {
# ----------------------------------------------------------------- system.time
if ($space eq 'time') {
@@ -1795,16 +1973,20 @@ sub numval {
sub rndseed {
my $symb;
unless ($symb=&symbread()) { return time; }
- my $symbchck=unpack("%32C*",$symb);
- my $symbseed=numval($symb)%$symbchck;
- my $namechck=unpack("%32C*",$ENV{'user.name'});
- my $nameseed=numval($ENV{'user.name'})%$namechck;
- return int( $symbseed
- .$nameseed
- .unpack("%32C*",$ENV{'user.domain'})
- .unpack("%32C*",$ENV{'request.course.id'})
- .$namechck
- .$symbchck);
+ {
+ use integer;
+ my $symbchck=unpack("%32C*",$symb) << 27;
+ my $symbseed=numval($symb) << 22;
+ my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;
+ my $nameseed=numval($ENV{'user.name'}) << 12;
+ my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;
+ my $courseseed=unpack("%32C*",$ENV{'request.course.id'});
+ 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;
+ }
}
sub ireceipt {