--- loncom/lonnet/perl/lonnet.pm 2006/01/13 10:35:58 1.683.2.11 +++ loncom/lonnet/perl/lonnet.pm 2005/12/22 20:56:28 1.687 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.683.2.11 2006/01/13 10:35:58 albertel Exp $ +# $Id: lonnet.pm,v 1.687 2005/12/22 20:56:28 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -271,7 +271,7 @@ sub transfer_profile_to_env { my %Remove; for ($envi=0;$envi<=$#profile;$envi++) { chomp($profile[$envi]); - my ($envname,$envvalue)=split(/=/,$profile[$envi],2); + my ($envname,$envvalue)=split(/=/,$profile[$envi]); $env{$envname} = $envvalue; if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { @@ -323,7 +323,7 @@ sub appenv { for (my $i=0; $i<=$#oldenv; $i++) { chomp($oldenv[$i]); if ($oldenv[$i] ne '') { - my ($name,$value)=split(/=/,$oldenv[$i],2); + my ($name,$value)=split(/=/,$oldenv[$i]); unless (defined($newenv{$name})) { $newenv{$name}=$value; } @@ -382,7 +382,7 @@ sub delenv { } foreach (@oldenv) { if ($_=~/^$delthis/) { - my ($key,undef) = split('=',$_,2); + my ($key,undef) = split('=',$_); delete($env{$key}); } else { print $fh $_; @@ -1280,8 +1280,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 { @@ -3010,9 +3017,8 @@ sub tmpput { # ------------------------------------------------------------ tmpget interface sub tmpget { - my ($token,$server)=@_; - if (!defined($server)) { $server = $perlvar{'lonHostID'}; } - my $rep=&reply("tmpget:$token",$server); + my ($token)=@_; + my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'}); my %returnhash; foreach my $item (split(/\&/,$rep)) { my ($key,$value)=split(/=/,$item); @@ -3021,13 +3027,6 @@ sub tmpget { return %returnhash; } -# ------------------------------------------------------------ tmpget interface -sub tmpdel { - my ($token,$server)=@_; - if (!defined($server)) { $server = $perlvar{'lonHostID'}; } - return &reply("tmpdel:$token",$server); -} - # ---------------------------------------------- Custom access rule evaluation sub customaccess { @@ -3346,21 +3345,17 @@ sub allowed { my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/\Q$rolecode\E/) { - if ($priv ne 'pch') { - &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. - 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. - $env{'request.course.id'}); - } + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. + $env{'request.course.id'}); return ''; } if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} =~/\Q$unamedom\E/) { - if ($priv ne 'pch') { - &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. - 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. - $env{'request.course.id'}); - } + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. + 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. + $env{'request.course.id'}); return ''; } } @@ -3370,11 +3365,9 @@ sub allowed { if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$env{'request.role'}))[0]; if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { - if ($priv ne 'pch') { - &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. - 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); - } - return ''; + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); + return ''; } } @@ -3405,8 +3398,7 @@ sub is_on_map { my $filename=$uriparts[$#uriparts]; my $pathname=$uri; $pathname=~s|/\Q$filename\E$||; - $pathname=~s/^adm\/wrapper\///; - $pathname=~s/^adm\/coursedocs\/showdoc\///; + $pathname=~s/^adm\/wrapper\///; #Trying to find the conditional for the file my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~ /\&\Q$filename\E\:([\d\|]+)\&/); @@ -3730,6 +3722,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; } @@ -4813,7 +4809,8 @@ sub EXT { return $env{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - my $section; + my ($section,$group); + my @groups = (); if (defined($courseid) && $courseid eq $env{'request.course.id'}) { if (!$symbparm) { $symbparm=&symbread(); } } @@ -4833,14 +4830,29 @@ sub EXT { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { $section=$env{'request.course.sec'}; + @groups=split(/:/,$env{'request.course.groups'}); + if (@groups > 0) { + @groups = sort(@groups); + $group = $groups[0]; + } } else { if (! defined($usection)) { $section=&getsection($udom,$uname,$courseid); } else { $section = $usection; } + my $grouplist = &get_users_groups($udom,$uname,$courseid); + if ($grouplist) { + @groups = split(/:/,$grouplist); + @groups = sort(@groups); + $group = $groups[0]; + } } + my $grplevel=$courseid.'.['.$group.'].'.$spacequalifierrest; + my $grplevelr=$courseid.'.['.$group.'].'.$symbparm; + my $grplevelm=$courseid.'.['.$group.'].'.$mapparm; + my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; @@ -4858,8 +4870,17 @@ sub EXT { if (defined($userreply)) { return $userreply; } # ------------------------------------------------ second, check some of course + my $coursereply; + if (defined($group)) { + $coursereply = &resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course', + ($grplevelr,$grplevelm,$grplevel, + $courselevelr)); + 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, @@ -4930,11 +4951,6 @@ sub EXT { if ($space eq 'time') { return time; } - } elsif ($realm eq 'server') { -# ----------------------------------------------------------------- system.time - if ($space eq 'name') { - return $ENV{'SERVER_NAME'}; - } } return ''; } @@ -5166,7 +5182,7 @@ sub metadata { $metaentry{':keys'}=join(',',keys %metathesekeys); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache_new('meta',$uri,\%metaentry,60*60); + &do_cache_new('meta',$uri,\%metaentry,60*60*24); # this is the end of "was not already recently cached } return $metaentry{':'.$what}; @@ -5299,7 +5315,6 @@ sub symbverify { my $thisfn=$thisurl; # wrapper not part of symbs $thisfn=~s/^\/adm\/wrapper//; - $thisfn=~s/^\/adm\/coursedocs\/showdoc\///; $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } @@ -5354,7 +5369,6 @@ sub symbclean { # remove wrapper $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; - $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/; return $symb; } @@ -6005,11 +6019,6 @@ sub filelocation { my ($dir,$file) = @_; my $location; $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces - - if ($file =~ m-^/adm/-) { - $file=~s-^/adm/wrapper/-/-; - $file=~s-^/adm/coursedocs/showdoc/-/-; - } if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; @@ -6049,9 +6058,6 @@ sub hreflocation { my ($dir,$file)=@_; unless (($file=~m-^http://-i) || ($file=~m-^/-)) { $file=filelocation($dir,$file); - } elsif ($file=~m-^/adm/-) { - $file=~s-^/adm/wrapper/-/-; - $file=~s-^/adm/coursedocs/showdoc/-/-; } if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { $file=~s-^\Q$perlvar{'lonDocRoot'}\E--; @@ -6095,8 +6101,6 @@ sub declutter { if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; $thisfn=~s/^\///; - $thisfn=~s|^adm/wrapper/||; - $thisfn=~s|^adm/coursedocs/showdoc/||; $thisfn=~s/^res\///; $thisfn=~s/\?.+$//; return $thisfn; @@ -6109,30 +6113,6 @@ sub clutter { unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { $thisfn='/res'.$thisfn; } - if ($thisfn !~m|/adm|) { - if ($thisfn =~ m|/ext/|) { - $thisfn='/adm/wrapper'.$thisfn; - } else { - my ($ext) = ($thisfn =~ /\.(\w+)$/); - my $embstyle=&Apache::loncommon::fileembstyle($ext); - if ($embstyle eq 'ssi' - || ($embstyle eq 'hdn') - || ($embstyle eq 'rat') - || ($embstyle eq 'prv') - || ($embstyle eq 'ign')) { - #do nothing with these - } elsif (($embstyle eq 'img') - || ($embstyle eq 'emb') - || ($embstyle eq 'wrp')) { - $thisfn='/adm/wrapper'.$thisfn; - } elsif ($embstyle eq 'unk' - && $thisfn!~/\.(sequence|page)$/) { - $thisfn='/adm/coursedocs/showdoc'.$thisfn; - } else { - &logthis("Got a blank emb style"); - } - } - } return $thisfn; } @@ -6276,7 +6256,7 @@ BEGIN { } close($config); # FIXME: dev server don't want this, production servers _do_ want this - &get_iphost(); + #&get_iphost(); } sub get_iphost {