--- loncom/lonnet/perl/lonnet.pm 2001/01/09 22:12:28 1.90 +++ loncom/lonnet/perl/lonnet.pm 2001/03/19 16:46:24 1.108 @@ -3,6 +3,8 @@ # # Functions for use by content handlers: # +# metadata_query(sql-query-string) : returns file handle of where sql +# 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 +15,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 @@ -84,6 +86,11 @@ # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer # 05/01/01 Guy Albertelli # 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 Scott Harrison package Apache::lonnet; @@ -234,7 +241,6 @@ sub critical { sub appenv { my %newenv=@_; - my ($in,$out); map { if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { &logthis("WARNING: ". @@ -244,23 +250,27 @@ 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>; - $in=$#oldenv+1; $fh->close(); } - &logthis("Number of elements read appenv: ".$in."from".join(" ",caller)); for (my $i=0; $i<=$#oldenv; $i++) { chomp($oldenv[$i]); if ($oldenv[$i] ne '') { @@ -276,20 +286,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: '.$!; - } - $out=0; - foreach $newname (sort keys %newenv) { + foreach $newname (keys %newenv) { print $fh "$newname=$newenv{$newname}\n"; - $out++; } $fh->close(); } - &logthis("Number of elements read appenv: ".$in." number out:".$out."from".join(" ",caller)); + + $lockfh->close(); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -695,8 +698,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, @@ -722,7 +724,7 @@ sub coursedescription { return (); } -# -------------------------------------------------------- Get user priviledges +# -------------------------------------------------------- Get user privileges sub rolesinit { my ($domain,$username,$authhost)=@_; @@ -796,12 +798,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; } } } @@ -911,7 +913,7 @@ sub eget { return %returnhash; } -# ------------------------------------------------- Check for a user priviledge +# ------------------------------------------------- Check for a user privilege sub allowed { my ($priv,$uri)=@_; @@ -962,7 +964,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 @@ -1013,7 +1015,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? @@ -1045,6 +1047,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; @@ -1182,6 +1185,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 { @@ -1209,12 +1219,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'}:". @@ -1618,11 +1638,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}; } @@ -1630,25 +1650,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=''; @@ -1831,16 +1865,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 {