--- loncom/lonnet/perl/lonnet.pm 2006/01/05 19:39:52 1.683.2.5
+++ loncom/lonnet/perl/lonnet.pm 2006/01/18 21:15:41 1.701
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.683.2.5 2006/01/05 19:39:52 albertel Exp $
+# $Id: lonnet.pm,v 1.701 2006/01/18 21:15:41 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]);
+ my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
$env{$envname} = $envvalue;
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {
@@ -289,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};
}
}
@@ -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;
}
@@ -380,12 +380,12 @@ sub delenv {
close($fh);
return 'error: '.$!;
}
- foreach (@oldenv) {
- if ($_=~/^$delthis/) {
- my ($key,undef) = split('=',$_);
+ foreach my $cur_key (@oldenv) {
+ if ($cur_key=~/^$delthis/) {
+ my ($key,undef) = split('=',$cur_key,2);
delete($env{$key});
} else {
- print $fh $_;
+ print $fh $cur_key;
}
}
close($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 {
@@ -1351,8 +1358,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') {
@@ -3405,7 +3420,8 @@ sub is_on_map {
my $filename=$uriparts[$#uriparts];
my $pathname=$uri;
$pathname=~s|/\Q$filename\E$||;
- $pathname=~s/^adm\/wrapper\///;
+ $pathname=~s/^adm\/wrapper\///;
+ $pathname=~s/^adm\/coursedocs\/showdoc\///;
#Trying to find the conditional for the file
my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
/\&\Q$filename\E\:([\d\|]+)\&/);
@@ -3729,6 +3745,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;
}
@@ -4812,10 +4832,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'}) {
@@ -4832,12 +4863,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;
@@ -4853,12 +4892,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,
@@ -4929,10 +4973,41 @@ sub EXT {
if ($space eq 'time') {
return time;
}
+ } elsif ($realm eq 'server') {
+# ----------------------------------------------------------------- system.time
+ if ($space eq 'name') {
+ return $ENV{'SERVER_NAME'};
+ }
}
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);
@@ -5160,7 +5235,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*24);
+ &do_cache_new('meta',$uri,\%metaentry,60*60);
# this is the end of "was not already recently cached
}
return $metaentry{':'.$what};
@@ -5293,6 +5368,7 @@ 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; }
@@ -5347,6 +5423,7 @@ sub symbclean {
# remove wrapper
$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
+ $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
return $symb;
}
@@ -5997,6 +6074,11 @@ 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:;
@@ -6036,6 +6118,9 @@ 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--;
@@ -6079,6 +6164,8 @@ 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;
@@ -6091,6 +6178,30 @@ 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;
}
@@ -6234,7 +6345,7 @@ BEGIN {
}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
- &get_iphost();
+ #&get_iphost();
}
sub get_iphost {