--- loncom/lonnet/perl/lonnet.pm 2006/05/15 23:42:52 1.683.2.21 +++ loncom/lonnet/perl/lonnet.pm 2006/02/14 20:28:57 1.711 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.683.2.21 2006/05/15 23:42:52 albertel Exp $ +# $Id: lonnet.pm,v 1.711 2006/02/14 20:28:57 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -124,7 +124,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 +152,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); @@ -272,8 +272,6 @@ 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) { @@ -291,14 +289,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}; } } @@ -326,8 +324,6 @@ 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; } @@ -340,7 +336,7 @@ sub appenv { } my $newname; foreach $newname (keys %newenv) { - print $fh &escape($newname).'='.&escape($newenv{$newname})."\n"; + print $fh "$newname=$newenv{$newname}\n"; } close($fh); } @@ -352,6 +348,7 @@ sub appenv { sub delenv { my $delthis=shift; + my %newenv=(); if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); @@ -384,10 +381,8 @@ sub delenv { return 'error: '.$!; } 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); + if ($cur_key=~/^$delthis/) { + my ($key,undef) = split('=',$cur_key,2); delete($env{$key}); } else { print $fh $cur_key; @@ -1150,7 +1145,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)); @@ -1322,8 +1319,15 @@ 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"} +# $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 { @@ -1393,8 +1397,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') { @@ -2820,7 +2832,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); @@ -2829,11 +2841,11 @@ 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; @@ -3850,6 +3862,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; } @@ -4653,30 +4669,11 @@ sub GetFileTimestamp { # -------------------------------------------------------- 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 { @@ -4684,49 +4681,43 @@ sub directcondval { } } -# get the collection of conditions for this resource sub condval { my $condidx=shift; + my $result=0; my $allpathcond=''; - foreach my $cond (split(/\|/,$condidx)) { - if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) { - $allpathcond.= - '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|'; - } + foreach (split(/\|/,$condidx)) { + if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) { + $allpathcond.= + '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|'; + } } $allpathcond=~s/\|$//; - 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; - } - } - } + 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 $result; } @@ -4958,10 +4949,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'}) { @@ -4970,7 +4972,7 @@ sub EXT { # ----------------------------------------------------- Cascading lookup scheme my $symbp=$symbparm; - my $mapp=&deversion((&decode_symb($symbp))[0]); + my $mapp=(&decode_symb($symbp))[0]; my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; @@ -4978,12 +4980,20 @@ 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); + if (@groups > 0) { + @groups = sort(@groups); + } } 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; @@ -4999,12 +5009,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, @@ -5084,6 +5099,32 @@ 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 = split/:/,$grouplist; + if (@groups > 1) { + @groups = sort(@groups); + } + return @groups; +} + sub packages_tab_default { my ($uri,$varname)=@_; my (undef,$part,$name)=split(/\./,$varname); @@ -5432,9 +5473,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'; @@ -6281,7 +6325,7 @@ sub clutter { && $thisfn!~/\.(sequence|page)$/) { $thisfn='/adm/coursedocs/showdoc'.$thisfn; } else { - #&logthis("Got a blank emb style"); + &logthis("Got a blank emb style"); } } } @@ -6428,7 +6472,7 @@ BEGIN { } close($config); # FIXME: dev server don't want this, production servers _do_ want this - &get_iphost(); + #&get_iphost(); } sub get_iphost { @@ -7131,10 +7175,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.