--- loncom/lonnet/perl/lonnet.pm 2005/11/17 16:58:23 1.680
+++ loncom/lonnet/perl/lonnet.pm 2006/01/10 16:06:07 1.692
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.680 2005/11/17 16:58:23 www Exp $
+# $Id: lonnet.pm,v 1.692 2006/01/10 16:06:07 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -40,8 +40,8 @@ qw(%perlvar %hostname %badServerCache %i
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
%domaindescription %domain_auth_def %domain_auth_arg_def
- %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit
- %env);
+ %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
+ $tmpdir $_64bit %env);
use IO::Socket;
use GDBM_File;
@@ -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 {
@@ -1853,28 +1860,25 @@ sub courseiddump {
# ---------------------------------------------------------- DC e-mail
sub dcmailput {
- my ($domain,$msgid,$contents,$server)=@_;
+ my ($domain,$msgid,$message,$server)=@_;
my $status = &Apache::lonnet::critical(
'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
- &Apache::lonnet::escape($$contents{$server}),$server);
+ &Apache::lonnet::escape($message),$server);
return $status;
}
sub dcmaildump {
my ($dom,$startdate,$enddate,$senders) = @_;
- my %returnhash=();
- foreach my $tryserver (keys(%libserv)) {
- if ($hostdom{$tryserver} eq $dom) {
- %{$returnhash{$tryserver}}=();
- my $cmd='dcmaildump:'.$dom.':'.
- &escape($startdate).':'.&escape($enddate).':';
- my @esc_senders=map { &escape($_)} @$senders;
- $cmd.=&escape(join('&',@esc_senders));
- foreach (split(/\&/,&reply($cmd,$tryserver))) {
- my ($key,$value) = split(/\=/,$_);
- if (($key) && ($value)) {
- $returnhash{$tryserver}{&unescape($key)} = &unescape($value);
- }
+ my %returnhash=();
+ if (exists($domain_primary{$dom})) {
+ my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
+ &escape($enddate).':';
+ my @esc_senders=map { &escape($_)} @$senders;
+ $cmd.=&escape(join('&',@esc_senders));
+ foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
+ my ($key,$value) = split(/\=/,$_);
+ if (($key) && ($value)) {
+ $returnhash{&unescape($key)} = &unescape($value);
}
}
}
@@ -2693,21 +2697,19 @@ sub set_userprivs {
my $author=0;
my $adv=0;
my %grouproles = ();
- my %groups_checked = ();
if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {
- my ($trole,$area);
- if ($role =~ m|^(\w+)\.(/\w+/\w+)|) {
+ my ($trole,$area,$sec,$extendedarea);
+ if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
$trole = $1;
$area = $2;
- unless ($groups_checked{$area}) {
- $groups_checked{$area} = 1;
- if (exists($$allgroups{$area})) {
- foreach my $group (keys(%{$$allgroups{$area}})) {
- my $spec = $trole.'.'.$area;
- $grouproles{$spec.'.'.$area.'/'.$group} =
- $$allgroups{$area}{$group};
- }
+ $sec = $3;
+ $extendedarea = $area.$sec;
+ if (exists($$allgroups{$area})) {
+ foreach my $group (keys(%{$$allgroups{$area}})) {
+ my $spec = $trole.'.'.$extendedarea;
+ $grouproles{$spec.'.'.$area.'/'.$group} =
+ $$allgroups{$area}{$group};
}
}
}
@@ -3015,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);
@@ -3025,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 {
@@ -3343,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 '';
}
}
@@ -3363,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 '';
}
}
@@ -3705,24 +3721,8 @@ sub auto_instcode_format {
# ------------------------------------------------------- Course Group routines
sub get_coursegroups {
- my ($cdom,$cnum,$curr_groups,$group) = @_;
- my $numgroups = 0;
- %{$curr_groups} = &dump('coursegroups',$cdom,$cnum,$group);
- my ($tmp)=keys(%{$curr_groups});
- if ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') {
- my %emptyhash = ();
- if (&put('coursegroups',\%emptyhash,$cdom,$cnum) eq 'ok') {
- %{$curr_groups} = &dump('coursegroups',$cdom,$cnum,$group);
- $tmp=keys(%{$curr_groups});
- }
- }
- if ($tmp=~/^error:/) {
- &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.$cdom);
- } else {
- my @groups = keys(%{$curr_groups});
- $numgroups = @groups;
- }
- return $numgroups;
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('coursegroups',$cdom,$cnum,$group));
}
sub modify_coursegroup {
@@ -3736,6 +3736,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;
}
@@ -3745,6 +3749,66 @@ sub modify_coursegroup_membership {
return $result;
}
+sub get_active_groups {
+ my ($udom,$uname,$cdom,$cnum) = @_;
+ my $now = time;
+ my %groups = ();
+ foreach my $key (keys(%env)) {
+ if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
+ my ($start,$end) = split(/\./,$env{$key});
+ if (($end!=0) && ($end<$now)) { next; }
+ if (($start!=0) && ($start>$now)) { next; }
+ if ($1 eq $cdom && $2 eq $cnum) {
+ $groups{$3} = $env{$key} ;
+ }
+ }
+ }
+ return %groups;
+}
+
+sub get_group_membership {
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('groupmembership',$cdom,$cnum,$group));
+}
+
+sub get_users_groups {
+ my ($udom,$uname,$courseid) = @_;
+ my $cachetime=1800;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+
+ my $hashid="$udom:$uname:$courseid";
+ my ($result,$cached)=&is_cached_new('getgroups',$hashid);
+ if (defined($cached)) { return $result; }
+
+ my %roleshash = &dump('roles',$udom,$uname,$courseid);
+ my ($tmp) = keys(%roleshash);
+ if ($tmp=~/^error:/) {
+ &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
+ return '';
+ } else {
+ my $grouplist;
+ foreach my $key (keys %roleshash) {
+ if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
+ unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership
+ $grouplist .= $1.':';
+ }
+ }
+ }
+ $grouplist =~ s/:$//;
+ return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
+ }
+}
+
+sub devalidate_getgroups_cache {
+ my ($udom,$uname,$cdom,$cnum)=@_;
+ my $courseid = $cdom.'_'.$cnum;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+ my $hashid="$udom:$uname:$courseid";
+ &devalidate_cache_new('getgroups',$hashid);
+}
+
# ------------------------------------------------------------------ Plain Text
sub plaintext {
@@ -4760,6 +4824,7 @@ sub EXT {
} elsif ($realm eq 'resource') {
my $section;
+ my @groups = ();
if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
if (!$symbparm) { $symbparm=&symbread(); }
}
@@ -4779,12 +4844,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;
@@ -4800,12 +4873,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,
@@ -4880,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);
@@ -5370,6 +5474,9 @@ sub symbread {
if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
$targetfn = 'adm/wrapper/'.$thisfn;
}
+ if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
+ $targetfn=$1;
+ }
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {
$syval=$hash{$targetfn};
@@ -6143,7 +6250,7 @@ BEGIN {
# next if /^\#/;
chomp;
my ($domain, $domain_description, $def_auth, $def_auth_arg,
- $def_lang, $city, $longi, $lati) = split(/:/,$_);
+ $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);
$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;
@@ -6151,6 +6258,7 @@ BEGIN {
$domain_city{$domain}=$city;
$domain_longi{$domain}=$longi;
$domain_lati{$domain}=$lati;
+ $domain_primary{$domain}=$primary;
# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );