--- loncom/lonnet/perl/lonnet.pm 2006/02/07 17:30:00 1.683.2.15 +++ loncom/lonnet/perl/lonnet.pm 2006/04/26 14:50:56 1.731 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.683.2.15 2006/02/07 17:30:00 albertel Exp $ +# $Id: lonnet.pm,v 1.731 2006/04/26 14:50:56 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -45,7 +45,6 @@ qw(%perlvar %hostname %badServerCache %i use IO::Socket; use GDBM_File; -use Apache::Constants qw(:common :http); use HTML::LCParser; use HTML::Parser; use Fcntl qw(:flock); @@ -86,6 +85,29 @@ delayed. # --------------------------------------------------------------------- Logging +{ + my $logid; + sub instructor_log { + my ($hash_name,$storehash,$delflag,$uname,$udom)=@_; + $logid++; + my $id=time().'00000'.$$.'00000'.$logid; + return &Apache::lonnet::put('nohist_'.$hash_name, + { $id => { + 'exe_uname' => $env{'user.name'}, + 'exe_udom' => $env{'user.domain'}, + 'exe_time' => time(), + 'exe_ip' => $ENV{'REMOTE_ADDR'}, + 'delflag' => $delflag, + 'logentry' => $storehash, + 'uname' => $uname, + 'udom' => $udom, + } + }, + $env{'course.'.$env{'request.course.id'}.'.domain'}, + $env{'course.'.$env{'request.course.id'}.'.num'} + ); + } +} sub logtouch { my $execdir=$perlvar{'lonDaemons'}; @@ -124,7 +146,7 @@ sub logperm { # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; - my $peerfile="$perlvar{'lonSockDir'}/$server"; + my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; # # With loncnew process trimming, there's a timing hole between lonc server # process exit and the master server picking up the listen on the AF_UNIX @@ -152,7 +174,7 @@ sub subreply { } my $answer; if ($client) { - print $client "$cmd\n"; + print $client "sethost:$server:$cmd\n"; $answer=<$client>; if (!$answer) { $answer="con_lost"; } chomp($answer); @@ -166,6 +188,7 @@ sub reply { my ($cmd,$server)=@_; unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); + &Apache::lonnet::logthis("$cmd"); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". " $cmd to $server returned $answer"); @@ -260,6 +283,13 @@ sub critical { sub transfer_profile_to_env { my ($lonidsdir,$handle)=@_; + if (!defined($lonidsdir)) { + $lonidsdir = $perlvar{'lonIDsDir'}; + } + if (!defined($handle)) { + ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); + } + my @profile; { open(my $idf,"$lonidsdir/$handle.id"); @@ -272,6 +302,8 @@ sub transfer_profile_to_env { for ($envi=0;$envi<=$#profile;$envi++) { chomp($profile[$envi]); my ($envname,$envvalue)=split(/=/,$profile[$envi],2); + $envname=&unescape($envname); + $envvalue=&unescape($envvalue); $env{$envname} = $envvalue; if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { @@ -289,14 +321,14 @@ sub transfer_profile_to_env { sub appenv { my %newenv=@_; - foreach (keys %newenv) { - if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { + foreach my $key (keys(%newenv)) { + if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) { &logthis("WARNING: ". - "Attempt to modify environment ".$_." to ".$newenv{$_} + "Attempt to modify environment ".$key." to ".$newenv{$key} .''); - delete($newenv{$_}); + delete($newenv{$key}); } else { - $env{$_}=$newenv{$_}; + $env{$key}=$newenv{$key}; } } @@ -324,6 +356,8 @@ sub appenv { chomp($oldenv[$i]); if ($oldenv[$i] ne '') { my ($name,$value)=split(/=/,$oldenv[$i],2); + $name=&unescape($name); + $value=&unescape($value); unless (defined($newenv{$name})) { $newenv{$name}=$value; } @@ -336,7 +370,7 @@ sub appenv { } my $newname; foreach $newname (keys %newenv) { - print $fh "$newname=$newenv{$newname}\n"; + print $fh &escape($newname).'='.&escape($newenv{$newname})."\n"; } close($fh); } @@ -348,7 +382,6 @@ sub appenv { sub delenv { my $delthis=shift; - my %newenv=(); if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); @@ -380,12 +413,14 @@ sub delenv { close($fh); return 'error: '.$!; } - foreach (@oldenv) { - if ($_=~/^$delthis/) { - my ($key,undef) = split('=',$_,2); + foreach my $cur_key (@oldenv) { + my $unescaped_cur_key = &unescape($cur_key); + if ($unescaped_cur_key=~/^$delthis/) { + my ($key) = split('=',$cur_key,2); + $key = &unescape($key); delete($env{$key}); } else { - print $fh $_; + print $fh $cur_key; } } close($fh); @@ -840,11 +875,9 @@ sub getsection { } sub save_cache { - my ($r)=@_; - if (! $r->is_initial_req()) { return DECLINED; } &purge_remembered(); + #&Apache::loncommon::validate_page(); undef(%env); - return OK; } my $to_remember=-1; @@ -948,7 +981,7 @@ sub studentphoto { my ($udom,$unam,$ext) = @_; my $home=&Apache::lonnet::homeserver($unam,$udom); if (defined($env{'request.course.id'})) { - if ($env{'course.'.$env{'request.course.id'}.'.internal.showphotos'}) { + if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) { if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) { return(&retrievestudentphoto($udom,$unam,$ext)); } else { @@ -996,13 +1029,13 @@ sub retrievestudentphoto { # -------------------------------------------------------------------- New chat sub chatsend { - my ($newentry,$anon)=@_; + my ($newentry,$anon,$group)=@_; my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'}; my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'}; my $chome=$env{'course.'.$env{'request.course.id'}.'.home'}; &reply('chatsend:'.$cdom.':'.$cnum.':'. &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'. - &escape($newentry)),$chome); + &escape($newentry)).':'.$group,$chome); } # ------------------------------------------ Find current version of a resource @@ -1145,7 +1178,9 @@ sub ssi { my $ua=new LWP::UserAgent; my $request; - + + $form{'no_update_last_known'}=1; + if (%form) { $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); @@ -1317,12 +1352,19 @@ sub clean_filename { } # --------------- Take an uploaded file and put it into the userfiles directory -# input: name of form element, coursedoc=1 means this is for the course -# output: url of file in userspace +# input: $formname - the contents of the file are in $env{"form.$formname"} +# the desired filenam is in $env{"form.$formname.filename"} +# $coursedoc - if true up to the current course +# if false +# $subdir - directory in userfile to store the file into +# $parser, $allfiles, $codebase - unknown +# +# output: url of file in userspace, or error: +# or /adm/notfound.html if failure to upload occurse sub userfileupload { - my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_; + my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_; if (!defined($subdir)) { $subdir='unknown'; } my $fname=$env{'form.'.$formname.'.filename'}; $fname=&clean_filename($fname); @@ -1345,6 +1387,7 @@ sub userfileupload { close($fh); return $fullpath.'/'.$fname; } + # Create the directory if not present $fname="$subdir/$fname"; if ($coursedoc) { @@ -1360,9 +1403,19 @@ sub userfileupload { $fname,$formname,$parser, $allfiles,$codebase); } + } elsif (defined($destuname)) { + my $docuname=$destuname; + my $docudom=$destudom; + return &finishuserfileupload($docuname,$docudom,$formname, + $fname,$parser,$allfiles,$codebase); + } else { my $docuname=$env{'user.name'}; my $docudom=$env{'user.domain'}; + if (exists($env{'form.group'})) { + $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; + $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; + } return &finishuserfileupload($docuname,$docudom,$formname, $fname,$parser,$allfiles,$codebase); } @@ -1388,8 +1441,16 @@ sub finishuserfileupload { } # Save the file { - open(FH,'>'.$filepath.'/'.$file); - print FH $env{'form.'.$formname}; + if (!open(FH,'>'.$filepath.'/'.$file)) { + &logthis('Failed to create '.$filepath.'/'.$file); + print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); + return '/adm/notfound.html'; + } + if (!print FH ($env{'form.'.$formname})) { + &logthis('Failed to write to '.$filepath.'/'.$file); + print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); + return '/adm/notfound.html'; + } close(FH); } if ($parser eq 'parse') { @@ -2540,7 +2601,7 @@ sub restore { # ---------------------------------------------------------- Course Description sub coursedescription { - my $courseid=shift; + my ($courseid,$args)=@_; $courseid=~s/^\///; $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); @@ -2550,7 +2611,27 @@ sub coursedescription { # trying and trying and trying to get the course description. my %envhash=(); my %returnhash=(); - $envhash{'course.'.$normalid.'.last_cache'}=time; + + my $expiretime=600; + if ($env{'request.course.id'} eq $normalid) { + $expiretime=120; + } + + my $prefix='course.'.$cdomain.'_'.$cnum.'.'; + if (!$args->{'freshen_cache'} + && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) { + foreach my $key (keys(%env)) { + next if ($key !~ /^\Q$prefix\E(.*)/); + my ($setting) = $1; + $returnhash{$setting} = $env{$key}; + } + return %returnhash; + } + + # get the data agin + if (!$args->{'one_time'}) { + $envhash{'course.'.$normalid.'.last_cache'}=time; + } if ($chome ne 'no_host') { %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { @@ -2568,7 +2649,9 @@ sub coursedescription { $envhash{'course.'.$normalid.'.num'}=$cnum; } } - &appenv(%envhash); + if (!$args->{'one_time'}) { + &appenv(%envhash); + } return %returnhash; } @@ -2815,7 +2898,7 @@ sub del { # -------------------------------------------------------------- dump interface sub dump { - my ($namespace,$udomain,$uname,$regexp)=@_; + my ($namespace,$udomain,$uname,$regexp,$range)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); @@ -2824,16 +2907,23 @@ sub dump { } else { $regexp='.'; } - my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome); + my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); foreach (@pairs) { - my ($key,$value)=split(/=/,$_); + my ($key,$value)=split(/=/,$_,2); $returnhash{unescape($key)}=&thaw_unescape($value); } return %returnhash; } +# --------------------------------------------------------- dumpstore interface + +sub dumpstore { + my ($namespace,$udomain,$uname,$regexp,$range)=@_; + return &dump($namespace,$udomain,$uname,$regexp,$range); +} + # -------------------------------------------------------------- keys interface sub getkeys { @@ -2975,25 +3065,53 @@ sub newput { # --------------------------------------------------------- putstore interface sub putstore { - my ($namespace,$storehash,$udomain,$uname)=@_; + my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; - my %allitems = (); - foreach (keys %$storehash) { - if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { - my $key = $1.':keys:'.$2; - $allitems{$key} .= $3.':'; - } - $items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; - } - foreach (keys %allitems) { - $allitems{$_} =~ s/\:$//; - $items.= $_.'='.$allitems{$_}.'&'; + foreach my $key (keys(%$storehash)) { + $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&'; } $items=~s/\&$//; - return &reply("put:$udomain:$uname:$namespace:$items",$uhome); + my $esc_symb=&escape($symb); + my $esc_v=&escape($version); + my $reply = + &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items", + $uhome); + if ($reply eq 'unknown_cmd') { + # gfall back to way things use to be done + return &old_putstore($namespace,$symb,$version,$storehash,$udomain, + $uname); + } + return $reply; +} + +sub old_putstore { + my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my %newstorehash; + foreach (keys %$storehash) { + my $key = $version.':'.&escape($symb).':'.$_; + $newstorehash{$key} = $storehash->{$_}; + } + my $items=''; + my %allitems = (); + foreach (keys %newstorehash) { + if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { + my $key = $1.':keys:'.$2; + $allitems{$key} .= $3.':'; + } + $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&'; + } + foreach (keys %allitems) { + $allitems{$_} =~ s/\:$//; + $items.= $_.'='.$allitems{$_}.'&'; + } + $items=~s/\&$//; + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } # ------------------------------------------------------ critical put interface @@ -3005,7 +3123,7 @@ sub cput { my $uhome=&homeserver($uname,$udomain); my $items=''; foreach (keys %$storehash) { - $items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $items=~s/\&$//; return &critical("put:$udomain:$uname:$namespace:$items",$uhome); @@ -3116,12 +3234,29 @@ sub allowed { } # Free bre access to user's own portfolio contents - my ($space,$domain,$name,$dir)=split('/',$uri); + my ($space,$domain,$name,@dir)=split('/',$uri); if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && - ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { + ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { return 'F'; } +# bre access to group if user has rgf priv for this group and course. + if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') + && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) { + if (exists($env{'request.course.id'})) { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + if (($domain eq $cdom) && ($name eq $cnum)) { + my $courseprivid=$env{'request.course.id'}; + $courseprivid=~s/\_/\//; + if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid + .'/'.$dir[1]} =~/rgf\&([^\:]*)/) { + return $1; + } + } + } + } + # Free bre to public access if ($priv eq 'bre') { @@ -3336,7 +3471,7 @@ sub allowed { my ($cdom,$cnum,$csec)=split(/\//,$courseid); my $prefix='course.'.$cdom.'_'.$cnum.'.'; if ((time-$env{$prefix.'last_cache'})>$expiretime) { - &coursedescription($courseid); + &coursedescription($courseid,{'freshen_cache' => 1}); } if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { @@ -3435,16 +3570,17 @@ sub allowed { return 'F'; } +sub split_uri_for_cond { + my $uri=&deversion(&declutter(shift)); + my @uriparts=split(/\//,$uri); + my $filename=pop(@uriparts); + my $pathname=join('/',@uriparts); + return ($pathname,$filename); +} # --------------------------------------------------- Is a resource on the map? sub is_on_map { - my $uri=&deversion(&declutter(shift)); - my @uriparts=split(/\//,$uri); - my $filename=$uriparts[$#uriparts]; - my $pathname=$uri; - $pathname=~s|/\Q$filename\E$||; - $pathname=~s/^adm\/wrapper\///; - $pathname=~s/^adm\/coursedocs\/showdoc\///; + my ($pathname,$filename) = &split_uri_for_cond(shift); #Trying to find the conditional for the file my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~ /\&\Q$filename\E\:([\d\|]+)\&/); @@ -3722,6 +3858,9 @@ sub auto_photo_permission { my $homeserver = &homeserver($cnum,$cdom); my ($outcome,$perm_reqd,$conditions) = split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3); + if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) { + return (undef,undef); + } return ($outcome,$perm_reqd,$conditions); } @@ -3732,6 +3871,9 @@ sub auto_checkphotos { my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'. &escape($uname).':'.&escape($pid), $homeserver)); + if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) { + return (undef,undef); + } if ($outcome) { ($result,$resulttype) = split(/:/,$outcome); } @@ -3744,6 +3886,9 @@ sub auto_photochoice { my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'. &escape($cdom), $homeserver))); + if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) { + return (undef,undef); + } return ($update,$comment); } @@ -3835,6 +3980,10 @@ sub modify_group_roles { 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; } @@ -3885,7 +4034,7 @@ sub get_users_groups { my $grouplist; foreach my $key (keys %roleshash) { if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { - unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership + unless ($roleshash{$key} =~ /_\d+_\-1$/) { # deleted membership $grouplist .= $1.':'; } } @@ -4636,13 +4785,69 @@ sub GetFileTimestamp { } } +sub stat_file { + my ($uri) = @_; + $uri = &clutter($uri); + + # we want just the url part without the unneeded accessor url bits + if ($uri =~ m-^/adm/-) { + $uri=~s-^/adm/wrapper/-/-; + $uri=~s-^/adm/coursedocs/showdoc/-/-; + } + my ($udom,$uname,$file,$dir); + if ($uri =~ m-^/(uploaded|editupload)/-) { + ($udom,$uname,$file) = + ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-); + $file = 'userfiles/'.$file; + $dir = &Apache::loncommon::propath($udom,$uname); + } + if ($uri =~ m-^/res/-) { + ($udom,$uname) = + ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-); + $file = $uri; + } + + if (!$udom || !$uname || !$file) { + # unable to handle the uri + return (); + } + + my ($result) = &dirlist($file,$udom,$uname,$dir); + my @stats = split('&', $result); + + if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + shift(@stats); #filename is first + return @stats; + } + return (); +} + # -------------------------------------------------------- Value of a Condition +# gets the value of a specific preevaluated condition +# stored in the string $env{user.state.} +# or looks up a condition reference in the bighash and if if hasn't +# already been evaluated recurses into docondval to get the value of +# the condition, then memoizing it to +# $env{user.state..} sub directcondval { my $number=shift; if (!defined($env{'user.state.'.$env{'request.course.id'}})) { &Apache::lonuserstate::evalstate(); } + if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) { + return $env{'user.state.'.$env{'request.course.id'}.".$number"}; + } elsif ($number =~ /^_/) { + my $sub_condition; + if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + $sub_condition=$bighash{'conditions'.$number}; + untie(%bighash); + } + my $value = &docondval($sub_condition); + &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value); + return $value; + } if ($env{'user.state.'.$env{'request.course.id'}}) { return substr($env{'user.state.'.$env{'request.course.id'}},$number,1); } else { @@ -4650,43 +4855,49 @@ sub directcondval { } } +# get the collection of conditions for this resource sub condval { my $condidx=shift; - my $result=0; my $allpathcond=''; - foreach (split(/\|/,$condidx)) { - if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) { - $allpathcond.= - '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|'; - } + foreach my $cond (split(/\|/,$condidx)) { + if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) { + $allpathcond.= + '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|'; + } } $allpathcond=~s/\|$//; - if ($env{'request.course.id'}) { - if ($allpathcond) { - my $operand='|'; - my @stack; - foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) { - if ($_ eq '(') { - push @stack,($operand,$result) - } elsif ($_ eq ')') { - my $before=pop @stack; - if (pop @stack eq '&') { - $result=$result>$before?$before:$result; - } else { - $result=$result>$before?$result:$before; - } - } elsif (($_ eq '&') || ($_ eq '|')) { - $operand=$_; - } else { - my $new=directcondval($_); - if ($operand eq '&') { - $result=$result>$new?$new:$result; - } else { - $result=$result>$new?$result:$new; - } - } - } - } + return &docondval($allpathcond); +} + +#evaluates an expression of conditions +sub docondval { + my ($allpathcond) = @_; + my $result=0; + if ($env{'request.course.id'} + && defined($allpathcond)) { + my $operand='|'; + my @stack; + foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) { + if ($chunk eq '(') { + push @stack,($operand,$result); + } elsif ($chunk eq ')') { + my $before=pop @stack; + if (pop @stack eq '&') { + $result=$result>$before?$before:$result; + } else { + $result=$result>$before?$result:$before; + } + } elsif (($chunk eq '&') || ($chunk eq '|')) { + $operand=$chunk; + } else { + my $new=directcondval($chunk); + if ($operand eq '&') { + $result=$result>$new?$new:$result; + } else { + $result=$result>$new?$result:$new; + } + } + } } return $result; } @@ -4803,8 +5014,8 @@ sub EXT_cache_set { # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb my $courseid; @@ -4918,10 +5129,21 @@ sub EXT { return $env{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - my $section; if (defined($courseid) && $courseid eq $env{'request.course.id'}) { if (!$symbparm) { $symbparm=&symbread(); } } + + if ($space eq 'title') { + if (!$symbparm) { $symbparm = $env{'request.filename'}; } + return &gettitle($symbparm); + } + + if ($space eq 'map') { + my ($map) = &decode_symb($symbparm); + return &symbread($map); + } + + my ($section, $group, @groups); my ($courselevelm,$courselevel); if ($symbparm && defined($courseid) && $courseid eq $env{'request.course.id'}) { @@ -4938,12 +5160,17 @@ sub EXT { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { $section=$env{'request.course.sec'}; + @groups=&sort_course_groups($env{'request.course.groups'},$courseid); } else { if (! defined($usection)) { $section=&getsection($udom,$uname,$courseid); } else { $section = $usection; } + my $grouplist = &get_users_groups($udom,$uname,$courseid); + if ($grouplist) { + @groups=&sort_course_groups($grouplist,$courseid); + } } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -4959,12 +5186,17 @@ sub EXT { my $userreply=&resdata($uname,$udom,'user', ($courselevelr,$courselevelm, $courselevel)); - if (defined($userreply)) { return $userreply; } # ------------------------------------------------ second, check some of course + my $coursereply; + if (@groups > 0) { + $coursereply = &check_group_parms($courseid,\@groups,$symbparm, + $mapparm,$spacequalifierrest); + 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, @@ -5044,6 +5276,29 @@ sub EXT { return ''; } +sub check_group_parms { + my ($courseid,$groups,$symbparm,$mapparm,$what) = @_; + my @groupitems = (); + my $resultitem; + my @levels = ($symbparm,$mapparm,$what); + foreach my $group (@{$groups}) { + foreach my $level (@levels) { + my $item = $courseid.'.['.$group.'].'.$level; + push(@groupitems,$item); + } + } + my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course',@groupitems); + return $coursereply; +} + +sub sort_course_groups { # Sort groups based on defined rankings. Default is sort(). + my ($grouplist,$courseid) = @_; + my @groups = sort(split(/:/,$grouplist)); + return @groups; +} + sub packages_tab_default { my ($uri,$varname)=@_; my (undef,$part,$name)=split(/\./,$varname); @@ -5392,9 +5647,12 @@ sub symblist { if (($env{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT(),0640)) { - foreach (keys %newhash) { - $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1], - $newhash{$_}->[0]); + foreach my $url (keys %newhash) { + next if ($url eq 'last_known' + && $env{'form.no_update_last_known'}); + $hash{declutter($url)}=&encode_symb($mapname, + $newhash{$url}->[1], + $newhash{$url}->[0]); } if (untie(%hash)) { return 'ok'; @@ -6241,7 +6499,7 @@ sub clutter { && $thisfn!~/\.(sequence|page)$/) { $thisfn='/adm/coursedocs/showdoc'.$thisfn; } else { - #&logthis("Got a blank emb style"); +# &logthis("Got a blank emb style"); } } } @@ -6309,7 +6567,6 @@ sub goodbye { &logthis(sprintf("%-20s is %s",'hits',$hits)); &flushcourselogs(); &logthis("Shutting down"); - return DONE; } BEGIN { @@ -6388,7 +6645,7 @@ BEGIN { } close($config); # FIXME: dev server don't want this, production servers _do_ want this - &get_iphost(); + #&get_iphost(); } sub get_iphost { @@ -7062,6 +7319,27 @@ all args are optional =item * +dumpstore($namespace,$udom,$uname,$regexp,$range) : +dumps the complete (or key matching regexp) namespace into a hash +($udom, $uname, $regexp, $range are optional) for a namespace that is +normally &store()ed into + +$range should be either an integer '100' (give me the first 100 + matching records) + or be two integers sperated by a - with no spaces + '30-50' (give me the 30th through the 50th matching + records) + + +=item * + +putstore($namespace,$symb,$version,$storehash,$udomain,$uname) : +replaces a &store() version of data with a replacement set of data +for a particular resource in a namespace passed in the $storehash hash +reference + +=item * + tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that works very similar to store/cstore, but all data is stored in a temporary location and can be reset using tmpreset, $storehash should @@ -7091,10 +7369,15 @@ namesp ($udom and $uname are optional) =item * -dump($namespace,$udom,$uname,$regexp) : +dump($namespace,$udom,$uname,$regexp,$range) : dumps the complete (or key matching regexp) namespace into a hash -($udom, $uname and $regexp are optional) +($udom, $uname, $regexp, $range are optional) +$range should be either an integer '100' (give me the first 100 + matching records) + or be two integers sperated by a - with no spaces + '30-50' (give me the 30th through the 50th matching + records) =item * inc($namespace,$store,$udom,$uname) : increments $store in $namespace. @@ -7110,17 +7393,6 @@ put($namespace,$storehash,$udom,$uname) =item * -putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp -keys used in storehash include version information (e.g., 1:$symb:message etc.) as -used in records written by &store and retrieved by &restore. This function -was created for use in editing discussion posts, without incrementing the -version number included in the key for a particular post. The colon -separated list of attribute names (e.g., the value associated with the key -1:keys:$symb) is also generated and passed in the ampersand separated -items sent to lonnet::reply(). - -=item * - cput($namespace,$storehash,$udom,$uname) : critical put ($udom and $uname are optional) @@ -7250,6 +7522,16 @@ getfile($file,$caller) : two cases - req - returns the entire contents of a file or -1; it properly subscribes to and replicates the file if neccessary. + +=item * + +stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file + reference + +returns either a stat() list of data about the file or an empty list +if the file doesn't exist or couldn't find out about it (connection +problems or user unknown) + =item * filelocation($dir,$file) : returns file system location of a file