--- loncom/lonnet/perl/lonnet.pm 2001/01/09 23:04:15 1.92 +++ loncom/lonnet/perl/lonnet.pm 2001/03/15 20:56:14 1.107 @@ -13,7 +13,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 @@ -85,7 +85,10 @@ # 05/01/01 Guy Albertelli # 05/01,06/01,09/01 Gerd Kortemeyer # 09/01 Guy Albertelli -# 09/01 Gerd Kortemeyer +# 09/01,10/01,11/01 Gerd Kortemeyer +# 02/27/01 Scott Harrison +# 3/2 Gerd Kortemeyer +# 3/15 Scott Harrison package Apache::lonnet; @@ -245,17 +248,23 @@ 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'; - } - unless (flock($fh,LOCK_SH)) { - &logthis("WARNING: ". - 'Could not obtain shared lock in appenv: '.$!); - $fh->close(); - return 'error: '.$!; + return 'error: '.$!; } @oldenv=<$fh>; $fh->close(); @@ -275,17 +284,13 @@ sub appenv { return 'error'; } my $newname; - unless (flock($fh,LOCK_EX)) { - &logthis("WARNING: ". - 'Could not obtain exclusive lock in appenv: '.$!); - $fh->close(); - return 'error: '.$!; - } - foreach $newname (sort keys %newenv) { + foreach $newname (keys %newenv) { print $fh "$newname=$newenv{$newname}\n"; } $fh->close(); } + + $lockfh->close(); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -691,8 +696,7 @@ sub coursedescription { 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 $normalid=$cdomain.'_'.$cnum; my %envhash=(); my %returnhash=('home' => $chome, 'domain' => $cdomain, @@ -718,7 +722,7 @@ sub coursedescription { return (); } -# -------------------------------------------------------- Get user priviledges +# -------------------------------------------------------- Get user privileges sub rolesinit { my ($domain,$username,$authhost)=@_; @@ -792,12 +796,12 @@ sub rolesinit { %thesepriv=(); 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; } } } @@ -907,7 +911,7 @@ sub eget { return %returnhash; } -# ------------------------------------------------- Check for a user priviledge +# ------------------------------------------------- Check for a user privilege sub allowed { my ($priv,$uri)=@_; @@ -958,7 +962,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 @@ -1009,7 +1013,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? @@ -1179,6 +1183,13 @@ sub definerole { } } +# ---------------- Make a metadata query against the network of library servers + +sub metadata_query { + my ($query)=@_; + my $reply=&reply("querysend:".&escape($query),'msul3'); +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -1206,12 +1217,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'}:". @@ -1615,11 +1636,11 @@ sub EXT { my $courselevelm= $ENV{'request.course.id'}.'.'.$mapparm; - # ----------------------------------------------------------- first, check user 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}; } @@ -1627,25 +1648,39 @@ sub EXT { 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=''; @@ -1828,16 +1863,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 {