--- loncom/lonnet/perl/lonnet.pm 2005/12/22 20:56:28 1.687
+++ loncom/lonnet/perl/lonnet.pm 2006/01/10 05:28:00 1.691
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.687 2005/12/22 20:56:28 albertel Exp $
+# $Id: lonnet.pm,v 1.691 2006/01/10 05:28:00 raeburn 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]);
+ my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
$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]);
+ my ($name,$value)=split(/=/,$oldenv[$i],2);
unless (defined($newenv{$name})) {
$newenv{$name}=$value;
}
@@ -382,7 +382,7 @@ sub delenv {
}
foreach (@oldenv) {
if ($_=~/^$delthis/) {
- my ($key,undef) = split('=',$_);
+ my ($key,undef) = split('=',$_,2);
delete($env{$key});
} else {
print $fh $_;
@@ -3017,8 +3017,9 @@ sub tmpput {
# ------------------------------------------------------------ tmpget interface
sub tmpget {
- my ($token)=@_;
- my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});
+ my ($token,$server)=@_;
+ if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
+ my $rep=&reply("tmpget:$token",$server);
my %returnhash;
foreach my $item (split(/\&/,$rep)) {
my ($key,$value)=split(/=/,$item);
@@ -3027,6 +3028,13 @@ 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 {
@@ -3345,17 +3353,21 @@ sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {
- &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
- 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
- $env{'request.course.id'});
+ 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'});
+ }
return '';
}
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {
- &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
- 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
- $env{'request.course.id'});
+ 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'});
+ }
return '';
}
}
@@ -3365,9 +3377,11 @@ sub allowed {
if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$env{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
- &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
- 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
- return '';
+ if ($priv ne 'pch') {
+ &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
+ 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
+ }
+ return '';
}
}
@@ -4809,7 +4823,7 @@ sub EXT {
return $env{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {
- my ($section,$group);
+ my $section;
my @groups = ();
if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
if (!$symbparm) { $symbparm=&symbread(); }
@@ -4830,10 +4844,9 @@ sub EXT {
if (($env{'user.name'} eq $uname) &&
($env{'user.domain'} eq $udom)) {
$section=$env{'request.course.sec'};
- @groups=split(/:/,$env{'request.course.groups'});
+ @groups=&sort_course_groups($env{'request.course.groups'},$courseid);
if (@groups > 0) {
@groups = sort(@groups);
- $group = $groups[0];
}
} else {
if (! defined($usection)) {
@@ -4843,16 +4856,10 @@ sub EXT {
}
my $grouplist = &get_users_groups($udom,$uname,$courseid);
if ($grouplist) {
- @groups = split(/:/,$grouplist);
- @groups = sort(@groups);
- $group = $groups[0];
+ @groups=&sort_course_groups($grouplist,$courseid);
}
}
- 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;
@@ -4866,17 +4873,13 @@ sub EXT {
my $userreply=&resdata($uname,$udom,'user',
($courselevelr,$courselevelm,
$courselevel));
-
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 (@groups > 0) {
+ $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
+ $mapparm,$spacequalifierrest);
if (defined($coursereply)) { return $coursereply; }
}
@@ -4955,6 +4958,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);