--- loncom/lonnet/perl/lonnet.pm 2005/11/01 15:07:29 1.674
+++ loncom/lonnet/perl/lonnet.pm 2006/02/10 10:01:32 1.709
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.674 2005/11/01 15:07:29 www Exp $
+# $Id: lonnet.pm,v 1.709 2006/02/10 10:01:32 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;
@@ -49,10 +49,11 @@ use Apache::Constants qw(:common :http);
use HTML::LCParser;
use HTML::Parser;
use Fcntl qw(:flock);
-use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;
+use Digest::MD5;
+
my $readit;
my $max_connection_retries = 10; # Or some such value.
@@ -123,7 +124,7 @@ sub logperm {
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
- my $peerfile="$perlvar{'lonSockDir'}/$server";
+ my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
#
# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX
@@ -151,7 +152,7 @@ sub subreply {
}
my $answer;
if ($client) {
- print $client "$cmd\n";
+ print $client "sethost:$server:$cmd\n";
$answer=<$client>;
if (!$answer) { $answer="con_lost"; }
chomp($answer);
@@ -270,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) {
@@ -288,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};
}
}
@@ -322,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;
}
@@ -379,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);
@@ -946,13 +947,50 @@ sub userenvironment {
sub studentphoto {
my ($udom,$unam,$ext) = @_;
my $home=&Apache::lonnet::homeserver($unam,$udom);
- 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';
+ 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 $tokenurl=&Apache::lonnet::tokenwrapper($url);
- return $tokenurl;
}
# -------------------------------------------------------------------- New chat
@@ -1279,8 +1317,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 {
@@ -1350,8 +1395,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') {
@@ -1852,28 +1905,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);
}
}
}
@@ -2574,15 +2624,17 @@ sub rolesinit {
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
my %allroles=();
+ my %allgroups=();
my $now=time;
my $userroles="user.login.time=$now\n";
+ my $group_privs;
if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;
- my ($trole,$tend,$tstart);
+ my ($trole,$tend,$tstart,$group_privs);
if ($role=~/^cr/) {
if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
@@ -2590,6 +2642,10 @@ sub rolesinit {
} else {
$trole=$role;
}
+ } elsif ($role =~ m|^gr/|) {
+ ($trole,$tend,$tstart) = split(/_/,$role);
+ ($trole,$group_privs) = split(/\//,$trole);
+ $group_privs = &unescape($group_privs);
} else {
($trole,$tend,$tstart)=split(/_/,$role);
}
@@ -2601,13 +2657,15 @@ sub rolesinit {
my ($tdummy,$tdomain,$trest)=split(/\//,$area);
if ($trole =~ /^cr\//) {
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+ } elsif ($trole eq 'gr') {
+ &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
} else {
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}
}
}
}
- my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
+ my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);
$userroles.='user.adv='.$adv."\n".
'user.author='.$author."\n";
$env{'user.adv'}=$adv;
@@ -2649,6 +2707,17 @@ sub custom_roleprivs {
}
}
+sub group_roleprivs {
+ my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
+ my $access = 1;
+ my $now = time;
+ if (($tend!=0) && ($tend<$now)) { $access = 0; }
+ if (($tstart!=0) && ($tstart>$now)) { $access=0; }
+ if ($access) {
+ my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);
+ $$allgroups{$course}{$group} .=':'.$group_privs;
+ }
+}
sub standard_roleprivs {
my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
@@ -2669,9 +2738,31 @@ sub standard_roleprivs {
}
sub set_userprivs {
- my ($userroles,$allroles) = @_;
+ my ($userroles,$allroles,$allgroups) = @_;
my $author=0;
my $adv=0;
+ my %grouproles = ();
+ if (keys(%{$allgroups}) > 0) {
+ foreach my $role (keys %{$allroles}) {
+ my ($trole,$area,$sec,$extendedarea);
+ if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
+ $trole = $1;
+ $area = $2;
+ $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};
+ }
+ }
+ }
+ }
+ }
+ foreach (keys(%grouproles)) {
+ $$allroles{$_} = $grouproles{$_};
+ }
foreach (keys %{$allroles}) {
my %thesepriv=();
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
@@ -2739,7 +2830,7 @@ sub del {
# -------------------------------------------------------------- dump interface
sub dump {
- my ($namespace,$udomain,$uname,$regexp)=@_;
+ my ($namespace,$udomain,$uname,$regexp,$range)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
@@ -2748,11 +2839,11 @@ sub dump {
} else {
$regexp='.';
}
- my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
+ my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
foreach (@pairs) {
- my ($key,$value)=split(/=/,$_);
+ my ($key,$value)=split(/=/,$_,2);
$returnhash{unescape($key)}=&thaw_unescape($value);
}
return %returnhash;
@@ -2971,8 +3062,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);
@@ -2981,6 +3073,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 {
@@ -3019,12 +3118,11 @@ sub customaccess {
sub allowed {
my ($priv,$uri,$symb)=@_;
+ my $ver_orguri=$uri;
$uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
-
-
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))
@@ -3071,7 +3169,7 @@ sub allowed {
if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
# uri is the requested domain in this case.
# comparison to 'request.role.domain' shows if the user has selected
- # a role of dc for the domain in question.
+ # a role of dc for the domain in question.
return 'F' if ($uri eq $env{'request.role.domain'});
}
@@ -3102,6 +3200,14 @@ sub allowed {
$thisallowed.=$1;
}
+# Group: uri itself is a group
+ my $groupuri=$uri;
+ $groupuri=~s/^([^\/])/\/$1/;
+ if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}
+ =~/\Q$priv\E\&([^\:]*)/) {
+ $thisallowed.=$1;
+ }
+
# URI is an uploaded document for this course, default permissions don't matter
# not allowing 'edit' access (editupload) to uploaded course docs
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
@@ -3113,7 +3219,7 @@ sub allowed {
$thisallowed.=$1;
}
} else {
- my $refuri=$env{'httpref.'.$orguri};
+ my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
if ($refuri) {
if ($refuri =~ m|^/adm/|) {
$thisallowed='F';
@@ -3293,17 +3399,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 '';
}
}
@@ -3313,9 +3423,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 '';
}
}
@@ -3346,7 +3458,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\|]+)\&/);
@@ -3619,6 +3732,82 @@ 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 = '';
@@ -3652,11 +3841,102 @@ sub auto_instcode_format {
return $response;
}
+# ------------------------------------------------------- Course Group routines
+
+sub get_coursegroups {
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('coursegroups',$cdom,$cnum,$group));
+}
+
+sub modify_coursegroup {
+ my ($cdom,$cnum,$groupsettings) = @_;
+ return(&put('coursegroups',$groupsettings,$cdom,$cnum));
+}
+
+sub modify_group_roles {
+ my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
+ my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
+ 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;
+}
+
+sub modify_coursegroup_membership {
+ my ($cdom,$cnum,$membership) = @_;
+ my $result = &put('groupmembership',$membership,$cdom,$cnum);
+ 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 {
my $short=shift;
- return &mt($prp{$short});
+ return &Apache::lonlocal::mt($prp{$short});
}
# ----------------------------------------------------------------- Assign Role
@@ -3674,6 +3954,16 @@ sub assignrole {
return 'refused';
}
$mrole='cr';
+ } elsif ($role =~ /^gr\//) {
+ my $cwogrp=$url;
+ $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ unless (&allowed('mdg',$cwogrp)) {
+ &logthis('Refused group assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+ $env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
+ $mrole='gr';
} else {
my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
@@ -3834,6 +4124,7 @@ sub modifyuser {
}
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
+ &devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.
@@ -4638,7 +4929,7 @@ sub EXT {
# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {
if ($qualifier eq 'textremote') {
- if (&mt('textual_remote_display') eq 'on') {
+ if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
return 1;
} else {
return 0;
@@ -4655,10 +4946,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'}) {
@@ -4675,12 +4977,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;
@@ -4696,12 +5006,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,
@@ -4772,10 +5087,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);
@@ -5003,7 +5349,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};
@@ -5099,10 +5445,17 @@ sub get_slot {
$cdom=$env{'course.'.$courseid.'.domain'};
$cnum=$env{'course.'.$courseid.'.num'};
}
- my %slotinfo=&get('slots',[$which],$cdom,$cnum);
- &Apache::lonhomework::showhash(%slotinfo);
- my ($tmp)=keys(%slotinfo);
- if ($tmp=~/^error:/) { return (); }
+ 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};
+ }
if (ref($slotinfo{$which}) eq 'HASH') {
return %{$slotinfo{$which}};
}
@@ -5136,6 +5489,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; }
@@ -5190,6 +5544,7 @@ sub symbclean {
# remove wrapper
$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
+ $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
return $symb;
}
@@ -5266,6 +5621,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};
@@ -5379,8 +5737,37 @@ sub numval3 {
return $total;
}
+sub digest {
+ my ($data)=@_;
+ my $digest=&Digest::MD5::md5($data);
+ my ($a,$b,$c,$d)=unpack("iiii",$digest);
+ my ($e,$f);
+ {
+ use integer;
+ $e=($a+$b);
+ $f=($c+$d);
+ if ($_64bit) {
+ $e=(($e<<32)>>32);
+ $f=(($f<<32)>>32);
+ }
+ }
+ if (wantarray) {
+ return ($e,$f);
+ } else {
+ my $g;
+ {
+ use integer;
+ $g=($e+$f);
+ if ($_64bit) {
+ $g=(($g<<32)>>32);
+ }
+ }
+ return $g;
+ }
+}
+
sub latest_rnd_algorithm_id {
- return '64bit4';
+ return '64bit5';
}
sub get_rand_alg {
@@ -5420,11 +5807,15 @@ sub rndseed {
if (!$username) { $username=$wusername }
my $which=&get_rand_alg();
if (defined(&getCODE())) {
- if ($which eq '64bit4') {
+ if ($which eq '64bit5') {
+ return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
+ } elsif ($which eq '64bit4') {
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
} else {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
}
+ } elsif ($which eq '64bit5') {
+ return &rndseed_64bit5($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit4') {
return &rndseed_64bit4($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit3') {
@@ -5547,6 +5938,12 @@ sub rndseed_64bit4 {
}
}
+sub rndseed_64bit5 {
+ my ($symb,$courseid,$domain,$username)=@_;
+ my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
+ return "$num1:$num2";
+}
+
sub rndseed_CODE_64bit {
my ($symb,$courseid,$domain,$username)=@_;
{
@@ -5585,6 +5982,13 @@ sub rndseed_CODE_64bit4 {
}
}
+sub rndseed_CODE_64bit5 {
+ my ($symb,$courseid,$domain,$username)=@_;
+ my $code = &getCODE();
+ my ($num1,$num2)=&digest("$symb,$courseid,$code");
+ return "$num1:$num2";
+}
+
sub setup_random_from_rndseed {
my ($rndseed)=@_;
if ($rndseed =~/([,:])/) {
@@ -5791,6 +6195,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:;
@@ -5830,6 +6239,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--;
@@ -5873,6 +6285,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;
@@ -5885,6 +6299,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;
}
@@ -5923,13 +6361,6 @@ sub thaw_unescape {
return &unescape($value);
}
-sub mod_perl_version {
- return 1;
- if (defined($perlvar{'MODPERL2'})) {
- return 2;
- }
-}
-
sub correct_line_ends {
my ($result)=@_;
$$result =~s/\r\n/\n/mg;
@@ -6000,7 +6431,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;
@@ -6008,6 +6439,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} );
@@ -6737,10 +7169,15 @@ namesp ($udom and $uname are optional)
=item *
-dump($namespace,$udom,$uname,$regexp) :
+dump($namespace,$udom,$uname,$regexp,$range) :
dumps the complete (or key matching regexp) namespace into a hash
-($udom, $uname and $regexp are optional)
+($udom, $uname, $regexp, $range are optional)
+$range should be either an integer '100' (give me the first 100
+ matching records)
+ or be two integers sperated by a - with no spaces
+ '30-50' (give me the 30th through the 50th matching
+ records)
=item *
inc($namespace,$store,$udom,$uname) : increments $store in $namespace.