--- loncom/lonnet/perl/lonnet.pm 2006/02/10 22:37:15 1.683.2.18
+++ loncom/lonnet/perl/lonnet.pm 2006/01/11 08:08:23 1.696
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.683.2.18 2006/02/10 22:37:15 albertel Exp $
+# $Id: lonnet.pm,v 1.696 2006/01/11 08:08:23 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -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("<font color=\"blue\">WARNING: ".
- "Attempt to modify environment ".$_." to ".$newenv{$_}
+ "Attempt to modify environment ".$key." to ".$newenv{$key}
.'</font>');
- delete($newenv{$_});
+ delete($newenv{$key});
} else {
- $env{$_}=$newenv{$_};
+ $env{$key}=$newenv{$key};
}
}
@@ -380,12 +380,12 @@ sub delenv {
close($fh);
return 'error: '.$!;
}
- foreach (@oldenv) {
- if ($_=~/^$delthis/) {
- my ($key,undef) = split('=',$_,2);
+ 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);
@@ -947,50 +947,13 @@ sub userenvironment {
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.showphoto'}) {
- if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
- return(&retrievestudentphoto($udom,$unam,$ext));
- } else {
- my ($result,$perm_reqd)=
- &Apache::lonnet::auto_photo_permission($unam,$udom);
- if ($result eq 'ok') {
- if (!($perm_reqd eq 'yes')) {
- return(&retrievestudentphoto($udom,$unam,$ext));
- }
- }
- }
- }
- } else {
- my ($result,$perm_reqd) =
- &Apache::lonnet::auto_photo_permission($unam,$udom);
- if ($result eq 'ok') {
- if (!($perm_reqd eq 'yes')) {
- return(&retrievestudentphoto($udom,$unam,$ext));
- }
- }
- }
- return '/adm/lonKaputt/lonlogo_broken.gif';
-}
-
-sub retrievestudentphoto {
- my ($udom,$unam,$ext,$type) = @_;
- my $home=&Apache::lonnet::homeserver($unam,$udom);
- my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
- if ($ret eq 'ok') {
- my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
- if ($type eq 'thumbnail') {
- $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
- }
- my $tokenurl=&Apache::lonnet::tokenwrapper($url);
- return $tokenurl;
- } else {
- if ($type eq 'thumbnail') {
- return '/adm/lonKaputt/genericstudent_tn.gif';
- } else {
- return '/adm/lonKaputt/lonlogo_broken.gif';
- }
+ my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home);
+ my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext;
+ if ($ret ne 'ok') {
+ return '/adm/lonKaputt/lonlogo_broken.gif';
}
+ my $tokenurl=&Apache::lonnet::tokenwrapper($url);
+ return $tokenurl;
}
# -------------------------------------------------------------------- New chat
@@ -1317,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: <message>
+# or /adm/notfound.html if failure to upload occurse
sub userfileupload {
@@ -3103,7 +3073,6 @@ sub customaccess {
sub allowed {
my ($priv,$uri,$symb)=@_;
- my $ver_orguri=$uri;
$uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
@@ -3204,7 +3173,7 @@ sub allowed {
$thisallowed.=$1;
}
} else {
- my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
+ my $refuri=$env{'httpref.'.$orguri};
if ($refuri) {
if ($refuri =~ m|^/adm/|) {
$thisallowed='F';
@@ -3435,17 +3404,16 @@ 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 ($pathname,$filename) = &split_uri_for_cond(shift);
+ 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\///;
#Trying to find the conditional for the file
my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
/\&\Q$filename\E\:([\d\|]+)\&/);
@@ -3718,82 +3686,6 @@ sub auto_create_password {
return ($authparam,$create_passwd,$authchk);
}
-sub auto_photo_permission {
- my ($cnum,$cdom,$students) = @_;
- 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);
-}
-
-sub auto_checkphotos {
- my ($uname,$udom,$pid) = @_;
- my $homeserver = &homeserver($uname,$udom);
- my ($result,$resulttype);
- 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);
- }
- return ($result,$resulttype);
-}
-
-sub auto_photochoice {
- my ($cnum,$cdom) = @_;
- my $homeserver = &homeserver($cnum,$cdom);
- 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);
-}
-
-sub auto_photoupdate {
- my ($affiliatesref,$dom,$cnum,$photo) = @_;
- my $homeserver = &homeserver($cnum,$dom);
- my $host=$hostname{$homeserver};
- my $cmd = '';
- my $maxtries = 1;
- foreach (keys %{$affiliatesref}) {
- $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
- }
- $cmd =~ s/%%$//;
- $cmd = &escape($cmd);
- my $query = 'institutionalphotos';
- my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
- unless ($queryid=~/^\Q$host\E\_/) {
- &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
- return 'error: '.$queryid;
- }
- my $reply = &get_query_reply($queryid);
- my $tries = 1;
- while (($reply=~/^timeout/) && ($tries < $maxtries)) {
- $reply = &get_query_reply($queryid);
- $tries ++;
- }
- if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
- &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
- } else {
- my @responses = split(/:/,$reply);
- my $outcome = shift(@responses);
- foreach my $item (@responses) {
- my ($key,$value) = split(/=/,$item);
- $$photo{$key} = $value;
- }
- return $outcome;
- }
- return 'error';
-}
-
sub auto_instcode_format {
my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
my $courses = '';
@@ -3845,6 +3737,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;
}
@@ -4928,10 +4824,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'}) {
@@ -4948,12 +4855,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;
@@ -4969,12 +4884,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,
@@ -5054,6 +4974,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);
@@ -5096,7 +5042,8 @@ sub metadata {
# if it is a non metadata possible uri return quickly
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
- ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
+ ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)
+ && ($uri !~ m|^adm/coursedocs/|) && ($uri !~ m|^adm/wrapper/|)) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
($uri =~ m|home/[^/]+/public_html/|)) {
return undef;
@@ -5281,7 +5228,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};
@@ -5377,17 +5324,10 @@ sub get_slot {
$cdom=$env{'course.'.$courseid.'.domain'};
$cnum=$env{'course.'.$courseid.'.num'};
}
- my $key=join("\0",'slots',$cdom,$cnum,$which);
- my %slotinfo;
- if (exists($remembered{$key})) {
- $slotinfo{$which} = $remembered{$key};
- } else {
- %slotinfo=&get('slots',[$which],$cdom,$cnum);
- &Apache::lonhomework::showhash(%slotinfo);
- my ($tmp)=keys(%slotinfo);
- if ($tmp=~/^error:/) { return (); }
- $remembered{$key} = $slotinfo{$which};
- }
+ my %slotinfo=&get('slots',[$which],$cdom,$cnum);
+ &Apache::lonhomework::showhash(%slotinfo);
+ my ($tmp)=keys(%slotinfo);
+ if ($tmp=~/^error:/) { return (); }
if (ref($slotinfo{$which}) eq 'HASH') {
return %{$slotinfo{$which}};
}
@@ -6127,11 +6067,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:;
@@ -6171,9 +6106,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--;
@@ -6217,10 +6149,10 @@ 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/\?.+$//;
+ $thisfn=~s|^adm/wrapper/||;
+ $thisfn=~s|^adm/coursedocs/showdoc/||;
return $thisfn;
}
@@ -6237,21 +6169,14 @@ sub clutter {
} 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')
+ if (($embstyle eq 'img')
|| ($embstyle eq 'emb')
|| ($embstyle eq 'wrp')) {
$thisfn='/adm/wrapper'.$thisfn;
- } elsif ($embstyle eq 'unk'
- && $thisfn!~/\.(sequence|page)$/) {
+ } elsif ($embstyle eq 'ssi') {
+ #do nothing with these
+ } elsif ($thisfn!~/\.(sequence|page)$/) {
$thisfn='/adm/coursedocs/showdoc'.$thisfn;
- } else {
- #&logthis("Got a blank emb style");
}
}
}
@@ -6398,7 +6323,7 @@ BEGIN {
}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
- &get_iphost();
+ #&get_iphost();
}
sub get_iphost {