--- loncom/lonnet/perl/lonnet.pm 2006/10/17 05:56:46 1.794
+++ loncom/lonnet/perl/lonnet.pm 2006/12/28 19:59:48 1.816
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.794 2006/10/17 05:56:46 albertel Exp $
+# $Id: lonnet.pm,v 1.816 2006/12/28 19:59:48 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -53,8 +53,7 @@ use Time::HiRes qw( gettimeofday tv_inte
use Cache::Memcached;
use Digest::MD5;
use Math::Random;
-use lib '/home/httpd/lib/perl';
-use LONCAPA;
+use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
my $readit;
@@ -413,17 +412,6 @@ sub delenv {
return 'ok';
}
-=pod
-
-=item * get_env_multiple($name)
-
-gets $name from the %env hash, it seemlessly handles the cases where multiple
-values may be defined and end up as an array ref.
-
-returns an array of values
-
-=cut
-
sub get_env_multiple {
my ($name) = @_;
my @values;
@@ -547,10 +535,10 @@ sub compare_server_load {
# --------------------------------------------- Try to change a user's password
sub changepass {
- my ($uname,$udom,$currentpass,$newpass,$server)=@_;
+ my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
$currentpass = &escape($currentpass);
$newpass = &escape($newpass);
- my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
+ my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
$server);
if (! $answer) {
&logthis("No reply on password change request to $server ".
@@ -599,8 +587,8 @@ sub queryauthenticate {
sub authenticate {
my ($uname,$upass,$udom)=@_;
- $upass=escape($upass);
- $uname=~s/\W//g;
+ $upass=&escape($upass);
+ $uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom);
if (!$uhome) {
&logthis("User $uname at $udom is unknown in authenticate");
@@ -675,8 +663,8 @@ sub idget {
sub idrget {
my ($udom,@unames)=@_;
my %returnhash=();
- foreach (@unames) {
- $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
+ foreach my $uname (@unames) {
+ $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
}
return %returnhash;
}
@@ -686,22 +674,69 @@ sub idrget {
sub idput {
my ($udom,%ids)=@_;
my %servers=();
- foreach (keys %ids) {
- &cput('environment',{'id'=>$ids{$_}},$udom,$_);
- my $uhom=&homeserver($_,$udom);
+ foreach my $uname (keys(%ids)) {
+ &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
+ my $uhom=&homeserver($uname,$udom);
if ($uhom ne 'no_host') {
- my $id=&escape($ids{$_});
+ my $id=&escape($ids{$uname});
$id=~tr/A-Z/a-z/;
- my $unam=&escape($_);
+ my $esc_unam=&escape($uname);
if ($servers{$uhom}) {
- $servers{$uhom}.='&'.$id.'='.$unam;
+ $servers{$uhom}.='&'.$id.'='.$esc_unam;
} else {
- $servers{$uhom}=$id.'='.$unam;
+ $servers{$uhom}=$id.'='.$esc_unam;
}
}
}
- foreach (keys %servers) {
- &critical('idput:'.$udom.':'.$servers{$_},$_);
+ foreach my $server (keys(%servers)) {
+ &critical('idput:'.$udom.':'.$servers{$server},$server);
+ }
+}
+
+# ------------------------------------------- get items from domain db files
+
+sub get_dom {
+ my ($namespace,$storearr,$udom)=@_;
+ my $items='';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
+ }
+ $items=~s/\&$//;
+ if (!$udom) { $udom=$env{'user.domain'}; }
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ my @pairs=split(/\&/,$rep);
+ if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
+ return @pairs;
+ }
+ my %returnhash=();
+ my $i=0;
+ foreach my $item (@$storearr) {
+ $returnhash{$item}=&thaw_unescape($pairs[$i]);
+ $i++;
+ }
+ return %returnhash;
+ } else {
+ &logthis("get_dom failed - no primary domain server for $udom");
+ }
+}
+
+# -------------------------------------------- put items in domain db files
+
+sub put_dom {
+ my ($namespace,$storehash,$udom)=@_;
+ if (!$udom) { $udom=$env{'user.domain'}; }
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ my $items='';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
+ }
+ $items=~s/\&$//;
+ return &reply("putdom:$udom:$namespace:$items",$uhome);
+ } else {
+ &logthis("put_dom failed - no primary domain server for $udom");
}
}
@@ -838,17 +873,32 @@ sub validate_access_key {
# ------------------------------------- Find the section of student in a course
sub devalidate_getsection_cache {
my ($udom,$unam,$courseid)=@_;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$unam:$courseid";
&devalidate_cache_new('getsection',$hashid);
}
+sub courseid_to_courseurl {
+ my ($courseid) = @_;
+ #already url style courseid
+ return $courseid if ($courseid =~ m{^/});
+
+ if (exists($env{'course.'.$courseid.'.num'})) {
+ my $cnum = $env{'course.'.$courseid.'.num'};
+ my $cdom = $env{'course.'.$courseid.'.domain'};
+ return "/$cdom/$cnum";
+ }
+
+ my %courseinfo=&Apache::lonnet::coursedescription($courseid);
+ if (exists($courseinfo{'num'})) {
+ return "/$courseinfo{'domain'}/$courseinfo{'num'}";
+ }
+
+ return undef;
+}
+
sub getsection {
my ($udom,$unam,$courseid)=@_;
my $cachetime=1800;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$unam:$courseid";
my ($result,$cached)=&is_cached_new('getsection',$hashid);
@@ -869,9 +919,10 @@ sub getsection {
# If there is more than one expired role, choose the one which ended last.
# If there is a role which has expired, return it.
#
- foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
- &homeserver($unam,$udom)))) {
- my ($key,$value)=split(/\=/,$_);
+ $courseid = &courseid_to_courseurl($courseid);
+ foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
+ &homeserver($unam,$udom)))) {
+ my ($key,$value)=split(/\=/,$line,2);
$key=&unescape($key);
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
my $section=$1;
@@ -1647,7 +1698,14 @@ sub removeuploadedurl {
sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;
my $home=&homeserver($docuname,$docudom);
- return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
+ my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
+ if ($result eq 'ok') {
+ if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
+ my $metafile = $fname.'.meta';
+ my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
+ }
+ }
+ return $result;
}
sub mkdiruserfile {
@@ -1659,8 +1717,17 @@ sub mkdiruserfile {
sub renameuserfile {
my ($docuname,$docudom,$old,$new)=@_;
my $home=&homeserver($docuname,$docudom);
- return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.
- &escape("$new"),$home);
+ my $result = &reply("renameuserfile:$docudom:$docuname:".
+ &escape("$old").':'.&escape("$new"),$home);
+ if ($result eq 'ok') {
+ if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
+ my $oldmeta = $old.'.meta';
+ my $newmeta = $new.'.meta';
+ my $metaresult =
+ &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
+ }
+ }
+ return $result;
}
# ------------------------------------------------------------------------- Log
@@ -1686,8 +1753,7 @@ sub flushcourselogs {
# times and course titles for all courseids
#
my %courseidbuffer=();
- foreach (keys %courselogs) {
- my $crsid=$_;
+ foreach my $crsid (keys %courselogs) {
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
&escape($courselogs{$crsid}),
$coursehombuf{$crsid}) eq 'ok') {
@@ -1714,8 +1780,8 @@ sub flushcourselogs {
# Write course id database (reverse lookup) to homeserver of courses
# Is used in pickcourse
#
- foreach (keys %courseidbuffer) {
- &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
+ foreach my $crsid (keys(%courseidbuffer)) {
+ &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
}
#
# File accesses
@@ -1724,7 +1790,8 @@ sub flushcourselogs {
foreach my $entry (keys(%accesshash)) {
if ($entry =~ /___count$/) {
my ($dom,$name);
- ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
+ ($dom,$name,undef)=
+ ($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
if (! defined($dom) || $dom eq '' ||
! defined($name) || $name eq '') {
my $cid = $env{'request.course.id'};
@@ -1745,7 +1812,7 @@ sub flushcourselogs {
}
}
} else {
- my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
+ my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
my %temphash=($entry => $accesshash{$entry});
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
delete $accesshash{$entry};
@@ -1756,8 +1823,7 @@ sub flushcourselogs {
# Roles
# Reverse lookup of user roles for course faculty/staff and co-authorship
#
- foreach (keys %userrolehash) {
- my $entry=$_;
+ foreach my $entry (keys(%userrolehash)) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=
split(/\:/,$entry);
if (&Apache::lonnet::put('nohist_userroles',
@@ -1829,9 +1895,9 @@ sub courseacclog {
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
$what.=':POST';
# FIXME: Probably ought to escape things....
- foreach (keys %env) {
- if ($_=~/^form\.(.*)/) {
- $what.=':'.$1.'='.$env{$_};
+ foreach my $key (keys(%env)) {
+ if ($key=~/^form\.(.*)/) {
+ $what.=':'.$1.'='.$env{$key};
}
}
} elsif ($fnsymb =~ m:^/adm/searchcat:) {
@@ -1893,19 +1959,19 @@ sub get_course_adv_roles {
$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);
my %nothide=();
- foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
- $nothide{join(':',split(/[\@\:]/,$_))}=1;
+ foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
+ $nothide{join(':',split(/[\@\:]/,$user))}=1;
}
my %returnhash=();
my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;
- foreach (keys %dumphash) {
- my ($tend,$tstart)=split(/\:/,$dumphash{$_});
+ foreach my $entry (keys %dumphash) {
+ my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }
- my ($role,$username,$domain,$section)=split(/\:/,$_);
+ my ($role,$username,$domain,$section)=split(/\:/,$entry);
if ($username eq '' || $domain eq '') { next; }
if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }
@@ -1929,12 +1995,12 @@ sub get_my_roles {
&dump('nohist_userroles',$udom,$uname);
my %returnhash=();
my $now=time;
- foreach (keys %dumphash) {
- my ($tend,$tstart)=split(/\:/,$dumphash{$_});
+ foreach my $entry (keys(%dumphash)) {
+ my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }
- my ($role,$username,$domain,$section)=split(/\:/,$_);
+ my ($role,$username,$domain,$section)=split(/\:/,$entry);
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}
return %returnhash;
@@ -1955,7 +2021,7 @@ sub getannounce {
if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
my $announcement='';
- while (<$fh>) { $announcement .=$_; }
+ while (my $line = <$fh>) { $announcement .= $line; }
close($fh);
if ($announcement=~/\w/) {
return
@@ -1985,12 +2051,12 @@ sub courseiddump {
foreach my $tryserver (keys %libserv) {
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
- foreach (
+ foreach my $line (
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
$sincefilter.':'.&escape($descfilter).':'.
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
$tryserver))) {
- my ($key,$value)=split(/\=/,$_);
+ my ($key,$value)=split(/\=/,$line,2);
if (($key) && ($value)) {
$returnhash{&unescape($key)}=$value;
}
@@ -2019,8 +2085,8 @@ sub dcmaildump {
&escape($enddate).':';
my @esc_senders=map { &escape($_)} @$senders;
$cmd.=&escape(join('&',@esc_senders));
- foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
- my ($key,$value) = split(/\=/,$_);
+ foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
+ my ($key,$value) = split(/\=/,$line,2);
if (($key) && ($value)) {
$returnhash{&unescape($key)} = &unescape($value);
}
@@ -2043,11 +2109,11 @@ sub get_domain_roles {
foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $dom) {
%{$personnel{$tryserver}}=();
- foreach (
+ foreach my $line (
split(/\&/,&reply('domrolesdump:'.$dom.':'.
&escape($startdate).':'.&escape($enddate).':'.
&escape($rolelist), $tryserver))) {
- my($key,$value) = split(/\=/,$_);
+ my ($key,$value) = split(/\=/,$line,2);
if (($key) && ($value)) {
$personnel{$tryserver}{&unescape($key)} = &unescape($value);
}
@@ -2269,27 +2335,27 @@ sub hash2str {
sub hashref2str {
my ($hashref)=@_;
my $result='__HASH_REF__';
- foreach (sort(keys(%$hashref))) {
- if (ref($_) eq 'ARRAY') {
- $result.=&arrayref2str($_).'=';
- } elsif (ref($_) eq 'HASH') {
- $result.=&hashref2str($_).'=';
- } elsif (ref($_)) {
+ foreach my $key (sort(keys(%$hashref))) {
+ if (ref($key) eq 'ARRAY') {
+ $result.=&arrayref2str($key).'=';
+ } elsif (ref($key) eq 'HASH') {
+ $result.=&hashref2str($key).'=';
+ } elsif (ref($key)) {
$result.='=';
- #print("Got a ref of ".(ref($_))." skipping.");
+ #print("Got a ref of ".(ref($key))." skipping.");
} else {
- if ($_) {$result.=&escape($_).'=';} else { last; }
+ if ($key) {$result.=&escape($key).'=';} else { last; }
}
- if(ref($hashref->{$_}) eq 'ARRAY') {
- $result.=&arrayref2str($hashref->{$_}).'&';
- } elsif(ref($hashref->{$_}) eq 'HASH') {
- $result.=&hashref2str($hashref->{$_}).'&';
- } elsif(ref($hashref->{$_})) {
+ if(ref($hashref->{$key}) eq 'ARRAY') {
+ $result.=&arrayref2str($hashref->{$key}).'&';
+ } elsif(ref($hashref->{$key}) eq 'HASH') {
+ $result.=&hashref2str($hashref->{$key}).'&';
+ } elsif(ref($hashref->{$key})) {
$result.='&';
- #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
+ #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
} else {
- $result.=&escape($hashref->{$_}).'&';
+ $result.=&escape($hashref->{$key}).'&';
}
}
$result=~s/\&$//;
@@ -2569,8 +2635,8 @@ sub store {
$$storehash{'host'}=$perlvar{'lonHostID'};
my $namevalue='';
- foreach (keys %$storehash) {
- $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $key (keys(%$storehash)) {
+ $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
}
$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
@@ -2605,8 +2671,8 @@ sub cstore {
$$storehash{'host'}=$perlvar{'lonHostID'};
my $namevalue='';
- foreach (keys %$storehash) {
- $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $key (keys(%$storehash)) {
+ $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
}
$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
@@ -2638,14 +2704,14 @@ sub restore {
my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
my %returnhash=();
- foreach (split(/\&/,$answer)) {
- my ($name,$value)=split(/\=/,$_);
+ foreach my $line (split(/\&/,$answer)) {
+ my ($name,$value)=split(/\=/,$line);
$returnhash{&unescape($name)}=&thaw_unescape($value);
}
my $version;
for ($version=1;$version<=$returnhash{'version'};$version++) {
- foreach (split(/\:/,$returnhash{$version.':keys'})) {
- $returnhash{$_}=$returnhash{$version.':'.$_};
+ foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
+ $returnhash{$item}=$returnhash{$version.':'.$item};
}
}
return %returnhash;
@@ -2685,6 +2751,7 @@ sub coursedescription {
if (!$args->{'one_time'}) {
$envhash{'course.'.$normalid.'.last_cache'}=time;
}
+
if ($chome ne 'no_host') {
%returnhash=&dump('environment',$cdomain,$cnum);
if (!exists($returnhash{'con_lost'})) {
@@ -2720,9 +2787,9 @@ sub privileged {
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
my $now=time;
if ($rolesdump ne '') {
- foreach (split(/&/,$rolesdump)) {
- if ($_!~/^rolesdef_/) {
- my ($area,$role)=split(/=/,$_);
+ foreach my $entry (split(/&/,$rolesdump)) {
+ if ($entry!~/^rolesdef_/) {
+ my ($area,$role)=split(/=/,$entry);
$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart)=split(/_/,$role);
if (($trole eq 'dc') || ($trole eq 'su')) {
@@ -2754,14 +2821,14 @@ sub rolesinit {
my $group_privs;
if ($rolesdump ne '') {
- foreach (split(/&/,$rolesdump)) {
- if ($_!~/^rolesdef_/) {
- my ($area,$role)=split(/=/,$_);
+ foreach my $entry (split(/&/,$rolesdump)) {
+ if ($entry!~/^rolesdef_/) {
+ my ($area,$role)=split(/=/,$entry);
$area=~s/\_\w\w$//;
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]+)_(.*)$|);
+ if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
+ ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
($tend,$tstart)=split('_',$trest);
} else {
$trole=$role;
@@ -2840,7 +2907,7 @@ sub group_roleprivs {
if (($tend!=0) && ($tend<$now)) { $access = 0; }
if (($tstart!=0) && ($tstart>$now)) { $access=0; }
if ($access) {
- my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);
+ my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
$$allgroups{$course}{$group} .=':'.$group_privs;
}
}
@@ -2871,7 +2938,7 @@ sub set_userprivs {
if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);
- if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) {
+ if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
$trole = $1;
$area = $2;
$sec = $3;
@@ -2886,15 +2953,15 @@ sub set_userprivs {
}
}
}
- foreach (keys(%grouproles)) {
- $$allroles{$_} = $grouproles{$_};
+ foreach my $group (keys(%grouproles)) {
+ $$allroles{$group} = $grouproles{$group};
}
- foreach (keys %{$allroles}) {
- my %thesepriv=();
- if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
- foreach (split(/:/,$$allroles{$_})) {
- if ($_ ne '') {
- my ($privilege,$restrictions)=split(/&/,$_);
+ foreach my $role (keys(%{$allroles})) {
+ my %thesepriv;
+ if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
+ foreach my $item (split(/:/,$$allroles{$role})) {
+ if ($item ne '') {
+ my ($privilege,$restrictions)=split(/&/,$item);
if ($restrictions eq '') {
$thesepriv{$privilege}='F';
} elsif ($thesepriv{$privilege} ne 'F') {
@@ -2904,8 +2971,10 @@ sub set_userprivs {
}
}
my $thesestr='';
- foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
- $userroles->{'user.priv.'.$_} = $thesestr;
+ foreach my $priv (keys(%thesepriv)) {
+ $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
+ }
+ $userroles->{'user.priv.'.$role} = $thesestr;
}
return ($author,$adv);
}
@@ -2915,8 +2984,8 @@ sub set_userprivs {
sub get {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- foreach (@$storearr) {
- $items.=escape($_).'&';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
}
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
@@ -2930,8 +2999,8 @@ sub get {
}
my %returnhash=();
my $i=0;
- foreach (@$storearr) {
- $returnhash{$_}=&thaw_unescape($pairs[$i]);
+ foreach my $item (@$storearr) {
+ $returnhash{$item}=&thaw_unescape($pairs[$i]);
$i++;
}
return %returnhash;
@@ -2942,8 +3011,8 @@ sub get {
sub del {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- foreach (@$storearr) {
- $items.=escape($_).'&';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
}
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
@@ -2993,8 +3062,9 @@ sub getkeys {
my $uhome=&homeserver($uname,$udomain);
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
my @keyarray=();
- foreach (split(/\&/,$rep)) {
- push (@keyarray,&unescape($_));
+ foreach my $key (split(/\&/,$rep)) {
+ next if ($key =~ /^error: 2 /);
+ push(@keyarray,&unescape($key));
}
return @keyarray;
}
@@ -3021,8 +3091,8 @@ sub currentdump {
%returnhash = %{&convert_dump_to_currentdump(\%hash)};
} else {
my @pairs=split(/\&/,$rep);
- foreach (@pairs) {
- my ($key,$value)=split(/=/,$_);
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair,2);
my ($symb,$param) = split(/:/,$key);
$returnhash{&unescape($symb)}->{&unescape($param)} =
&thaw_unescape($value);
@@ -3100,8 +3170,8 @@ sub put {
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my $items='';
- foreach (keys %$storehash) {
- $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
@@ -3153,22 +3223,22 @@ sub old_putstore {
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my %newstorehash;
- foreach (keys %$storehash) {
- my $key = $version.':'.&escape($symb).':'.$_;
- $newstorehash{$key} = $storehash->{$_};
+ foreach my $item (keys(%$storehash)) {
+ my $key = $version.':'.&escape($symb).':'.$item;
+ $newstorehash{$key} = $storehash->{$item};
}
my $items='';
my %allitems = ();
- foreach (keys %newstorehash) {
- if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
+ foreach my $item (keys(%newstorehash)) {
+ if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
my $key = $1.':keys:'.$2;
$allitems{$key} .= $3.':';
}
- $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&';
+ $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
}
- foreach (keys %allitems) {
- $allitems{$_} =~ s/\:$//;
- $items.= $_.'='.$allitems{$_}.'&';
+ foreach my $item (keys(%allitems)) {
+ $allitems{$item} =~ s/\:$//;
+ $items.= $item.'='.$allitems{$item}.'&';
}
$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
@@ -3182,8 +3252,8 @@ sub cput {
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my $items='';
- foreach (keys %$storehash) {
- $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
@@ -3194,8 +3264,8 @@ sub cput {
sub eget {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- foreach (@$storearr) {
- $items.=escape($_).'&';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
}
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
@@ -3205,8 +3275,8 @@ sub eget {
my @pairs=split(/\&/,$rep);
my %returnhash=();
my $i=0;
- foreach (@$storearr) {
- $returnhash{$_}=&thaw_unescape($pairs[$i]);
+ foreach my $item (@$storearr) {
+ $returnhash{$item}=&thaw_unescape($pairs[$i]);
$i++;
}
return %returnhash;
@@ -3214,12 +3284,15 @@ sub eget {
# ------------------------------------------------------------ tmpput interface
sub tmpput {
- my ($storehash,$server)=@_;
+ my ($storehash,$server,$context)=@_;
my $items='';
- foreach (keys(%$storehash)) {
- $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
+ if (defined($context)) {
+ $items .= ':'.&escape($context);
+ }
return &reply("tmpput:$items",$server);
}
@@ -3249,6 +3322,22 @@ sub portfolio_access {
my ($requrl) = @_;
my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
+ if ($result) {
+ my %setters;
+ if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
+ my ($startblock,$endblock) =
+ &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
+ if ($startblock && $endblock) {
+ return 'B';
+ }
+ } else {
+ my ($startblock,$endblock) =
+ &Apache::loncommon::blockcheck(\%setters,'port');
+ if ($startblock && $endblock) {
+ return 'B';
+ }
+ }
+ }
if ($result eq 'ok') {
return 'F';
} elsif ($result =~ /^[^:]+:guest_/) {
@@ -3324,7 +3413,7 @@ sub get_portfolio_access {
my (%allgroups,%allroles);
my ($start,$end,$role,$sec,$group);
foreach my $envkey (%env) {
- if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) {
+ if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;
if ($1 eq 'gr') {
$group = $4;
@@ -3337,7 +3426,7 @@ sub get_portfolio_access {
}
$allroles{$cid}{$1}{$sec} = $env{$envkey};
}
- } elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) {
+ } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;
if ($4 eq '') {
$sec = 'none';
@@ -3432,12 +3521,12 @@ sub parse_portfolio_url {
my ($type,$udom,$unum,$group,$file_name);
- if ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) {
+ if ($url =~ m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) {
$type = 1;
$udom = $1;
$unum = $2;
$file_name = $3;
- } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) {
+ } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
$type = 2;
$udom = $1;
$unum = $2;
@@ -3455,21 +3544,31 @@ sub is_portfolio_url {
return scalar(&parse_portfolio_url($url));
}
+sub is_portfolio_file {
+ my ($file) = @_;
+ if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w\/portfolio/)) {
+ return 1;
+ }
+ return;
+}
+
+
# ---------------------------------------------- Custom access rule evaluation
sub customaccess {
my ($priv,$uri)=@_;
- my ($urole,$urealm)=split(/\./,$env{'request.role'});
- $urealm=~s/^\W//;
+ my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
my ($udom,$ucrs,$usec)=split(/\//,$urealm);
+ $udom = &LONCAPA::clean_domain($udom);
+ $ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;
- foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
- my ($effect,$realm,$role)=split(/\:/,$_);
+ foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
+ my ($effect,$realm,$role)=split(/\:/,$right);
if ($role) {
if ($role ne $urole) { next; }
}
- foreach (split(/\s*\,\s*/,$realm)) {
- my ($tdom,$tcrs,$tsec)=split(/\_/,$_);
+ foreach my $scope (split(/\s*\,\s*/,$realm)) {
+ my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
if ($tdom) {
if ($tdom ne $udom) { next; }
}
@@ -3492,12 +3591,21 @@ sub customaccess {
# ------------------------------------------------- Check for a user privilege
sub allowed {
- my ($priv,$uri,$symb)=@_;
+ my ($priv,$uri,$symb,$role)=@_;
my $ver_orguri=$uri;
$uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
-
+
+ if ($priv eq 'evb') {
+# Evade communication block restrictions for specified role in a course
+ if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
+ return $1;
+ } else {
+ return;
+ }
+ }
+
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
@@ -3510,7 +3618,14 @@ sub allowed {
my ($space,$domain,$name,@dir)=split('/',$uri);
if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
- return 'F';
+ my %setters;
+ my ($startblock,$endblock) =
+ &Apache::loncommon::blockcheck(\%setters,'port');
+ if ($startblock && $endblock) {
+ return 'B';
+ } else {
+ return 'F';
+ }
}
# bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
@@ -3681,14 +3796,14 @@ sub allowed {
if ($checkreferer) {
my $refuri=$env{'httpref.'.$orguri};
unless ($refuri) {
- foreach (keys %env) {
- if ($_=~/^httpref\..*\*/) {
- my $pattern=$_;
+ foreach my $key (keys(%env)) {
+ if ($key=~/^httpref\..*\*/) {
+ my $pattern=$key;
$pattern=~s/^httpref\.\/res\///;
$pattern=~s/\*/\[\^\/\]\+/g;
$pattern=~s/\//\\\//g;
if ($orguri=~/$pattern/) {
- $refuri=$env{$_};
+ $refuri=$env{$key};
}
}
}
@@ -3786,6 +3901,8 @@ sub allowed {
unless ($env{'request.course.id'}) {
if ($thisallowed eq 'A') {
return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
} else {
return '1';
}
@@ -3853,6 +3970,8 @@ sub allowed {
if ($thisallowed eq 'A') {
return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
}
return 'F';
}
@@ -3906,8 +4025,8 @@ sub get_symb_from_alias {
sub definerole {
if (allowed('mcr','/')) {
my ($rolename,$sysrole,$domrole,$courole)=@_;
- foreach (split(':',$sysrole)) {
- my ($crole,$cqual)=split(/\&/,$_);
+ foreach my $role (split(':',$sysrole)) {
+ my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
@@ -3915,8 +4034,8 @@ sub definerole {
}
}
}
- foreach (split(':',$domrole)) {
- my ($crole,$cqual)=split(/\&/,$_);
+ foreach my $role (split(':',$domrole)) {
+ my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {
@@ -3924,8 +4043,8 @@ sub definerole {
}
}
}
- foreach (split(':',$courole)) {
- my ($crole,$cqual)=split(/\&/,$_);
+ foreach my $role (split(':',$courole)) {
+ my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
@@ -3972,7 +4091,7 @@ sub log_query {
my $uhome=&homeserver($uname,$udom);
if ($uhome eq 'no_host') { return 'error: no_host'; }
my $uhost=$hostname{$uhome};
- my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));
+ my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);
unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
@@ -3993,8 +4112,8 @@ sub fetch_enrollment_query {
}
my $host=$hostname{$homeserver};
my $cmd = '';
- foreach (keys %{$affiliatesref}) {
- $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
+ foreach my $affiliate (keys %{$affiliatesref}) {
+ $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}
$cmd =~ s/%%$//;
$cmd = &escape($cmd);
@@ -4015,18 +4134,18 @@ sub fetch_enrollment_query {
} else {
my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {
- foreach (@responses) {
- my ($key,$value) = split/=/,$_;
+ foreach my $line (@responses) {
+ my ($key,$value) = split(/=/,$line,2);
$$replyref{$key} = $value;
}
} else {
my $pathname = $perlvar{'lonDaemons'}.'/tmp';
- foreach (@responses) {
- my ($key,$value) = split/=/,$_;
+ foreach my $line (@responses) {
+ my ($key,$value) = split(/=/,$line);
$$replyref{$key} = $value;
if ($value > 0) {
- foreach (@{$$affiliatesref{$key}}) {
- my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
+ foreach my $item (@{$$affiliatesref{$key}}) {
+ my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
my $destname = $pathname.'/'.$filename;
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
if ($xml_classlist =~ /^error/) {
@@ -4185,8 +4304,8 @@ sub auto_photoupdate {
my $host=$hostname{$homeserver};
my $cmd = '';
my $maxtries = 1;
- foreach (keys %{$affiliatesref}) {
- $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
+ foreach my $affiliate (keys(%{$affiliatesref})) {
+ $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}
$cmd =~ s/%%$//;
$cmd = &escape($cmd);
@@ -4277,13 +4396,13 @@ sub auto_instcode_defaults {
foreach my $pair (split(/\&/,$response)) {
my ($name,$value)=split(/\=/,$pair);
if ($name eq 'code_order') {
- $code_order = [split(/\&/,&unescape($value))];
+ @{$code_order} = split(/\&/,&unescape($value));
} else {
- $$returnhash{&unescape($name)}=&unescape($value);
+ $returnhash->{&unescape($name)}=&unescape($value);
}
}
+ $ok_response = 1;
}
- $ok_response = 1;
}
if ($ok_response) {
return 'ok';
@@ -4303,8 +4422,8 @@ sub auto_validate_class_sec {
# ------------------------------------------------------- Course Group routines
sub get_coursegroups {
- my ($cdom,$cnum,$group) = @_;
- return(&dump('coursegroups',$cdom,$cnum,$group));
+ my ($cdom,$cnum,$group,$namespace) = @_;
+ return(&dump($namespace,$cdom,$cnum,$group));
}
sub modify_coursegroup {
@@ -4312,6 +4431,37 @@ sub modify_coursegroup {
return(&put('coursegroups',$groupsettings,$cdom,$cnum));
}
+sub toggle_coursegroup_status {
+ my ($cdom,$cnum,$group,$action) = @_;
+ my ($from_namespace,$to_namespace);
+ if ($action eq 'delete') {
+ $from_namespace = 'coursegroups';
+ $to_namespace = 'deleted_groups';
+ } else {
+ $from_namespace = 'deleted_groups';
+ $to_namespace = 'coursegroups';
+ }
+ my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
+ if (my $tmp = &error(%curr_group)) {
+ &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
+ return ('read error',$tmp);
+ } else {
+ my %savedsettings = %curr_group;
+ my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
+ my $deloutcome;
+ if ($result eq 'ok') {
+ $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
+ } else {
+ return ('write error',$result);
+ }
+ if ($deloutcome eq 'ok') {
+ return 'ok';
+ } else {
+ return ('delete error',$deloutcome);
+ }
+ }
+}
+
sub modify_group_roles {
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
@@ -4335,7 +4485,7 @@ sub get_active_groups {
my $now = time;
my %groups = ();
foreach my $key (keys(%env)) {
- if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
+ if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
my ($start,$end) = split(/\./,$env{$key});
if (($end!=0) && ($end<$now)) { next; }
if (($start!=0) && ($start>$now)) { next; }
@@ -4356,8 +4506,6 @@ sub get_users_groups {
my ($udom,$uname,$courseid) = @_;
my @usersgroups;
my $cachetime=1800;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$uname:$courseid";
my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
@@ -4365,7 +4513,8 @@ sub get_users_groups {
@usersgroups = split(/:/,$grouplist);
} else {
$grouplist = '';
- my %roleshash = &dump('roles',$udom,$uname,$courseid);
+ my $courseurl = &courseid_to_courseurl($courseid);
+ my %roleshash = &dump('roles',$udom,$uname,$courseurl);
my ($tmp) = keys(%roleshash);
if ($tmp=~/^error:/) {
&logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
@@ -4374,7 +4523,7 @@ sub get_users_groups {
'.default_enrollment_end_date'};
my $now = time;
foreach my $key (keys(%roleshash)) {
- if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
+ if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
my $group = $1;
if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
my $start = $2;
@@ -4404,8 +4553,7 @@ sub get_users_groups {
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);
}
@@ -4444,7 +4592,7 @@ sub assignrole {
my $mrole;
if ($role =~ /^cr\//) {
my $cwosec=$url;
- $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {
&logthis('Refused custom assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -4454,7 +4602,7 @@ sub assignrole {
$mrole='cr';
} elsif ($role =~ /^gr\//) {
my $cwogrp=$url;
- $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
unless (&allowed('mdg',$cwogrp)) {
&logthis('Refused group assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -4464,7 +4612,7 @@ sub assignrole {
$mrole='gr';
} else {
my $cwosec=$url;
- $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {
&logthis('Refused assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -4544,8 +4692,8 @@ sub modifyuser {
$umode, $upass, $first,
$middle, $last, $gene,
$forceid, $desiredhome, $email)=@_;
- $udom=~s/\W//g;
- $uname=~s/\W//g;
+ $udom= &LONCAPA::clean_domain($udom);
+ $uname=&LONCAPA::clean_username($uname);
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.'(forceid: '.$forceid.')'.
@@ -4694,8 +4842,8 @@ sub modify_student_enrollment {
['firstname','middlename','lastname', 'generation','id']
,$udom,$uname);
- #foreach (keys(%tmp)) {
- # &logthis("key $_ = ".$tmp{$_});
+ #foreach my $key (keys(%tmp)) {
+ # &logthis("key $key = ".$tmp{$key});
#}
$first = $tmp{'firstname'} if (!defined($first) || $first eq '');
$middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
@@ -4753,8 +4901,8 @@ sub writecoursepref {
return 'error: no such course';
}
my $cstring='';
- foreach (keys %prefs) {
- $cstring.=escape($_).'='.escape($prefs{$_}).'&';
+ foreach my $pref (keys(%prefs)) {
+ $cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
}
$cstring=~s/\&$//;
return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
@@ -4830,6 +4978,16 @@ ENDINITMAP
return '/'.$udom.'/'.$uname;
}
+sub is_course {
+ my ($cdom,$cnum) = @_;
+ my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
+ undef,'.');
+ if (exists($courses{$cdom.'_'.$cnum})) {
+ return 1;
+ }
+ return 0;
+}
+
# ---------------------------------------------------------- Assign Custom Role
sub assigncustomrole {
@@ -4961,20 +5119,20 @@ sub files_not_in_path {
my $filename = $user."savedfiles";
my @return_files;
my $path_part;
- open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
- while (<IN>) {
+ open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ while (my $line = <IN>) {
#ok, I know it's clunky, but I want it to work
- my @paths_and_file = split m!/!, $_;
- my $file_part = pop (@paths_and_file);
- chomp ($file_part);
- my $path_part = join ('/', @paths_and_file);
+ my @paths_and_file = split(m|/|, $line);
+ my $file_part = pop(@paths_and_file);
+ chomp($file_part);
+ my $path_part = join('/', @paths_and_file);
$path_part .= '/';
my $path_and_file = $path_part.$file_part;
if ($path_part ne $path) {
- push (@return_files, ($path_and_file));
+ push(@return_files, ($path_and_file));
}
}
- close (OUT);
+ close(OUT);
return (@return_files);
}
@@ -5037,8 +5195,13 @@ sub modify_access_controls {
for (my $i=0; $i<$numnew; $i++) {
my $newkey = $newitems[$i];
my $newid = &Apache::loncommon::get_cgi_id();
- $newkey =~ s/^(\d+)/$newid/;
- $translation{$1} = $newid;
+ if ($newkey =~ /^\d+:/) {
+ $newkey =~ s/^(\d+)/$newid/;
+ $translation{$1} = $newid;
+ } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
+ $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
+ $translation{$1} = $newid;
+ }
$new_values{$file_name."\0".$newkey} =
$$changes{'activate'}{$newitems[$i]};
$new_control{$newkey} = $now;
@@ -5238,28 +5401,27 @@ sub dirlist {
if($udom) {
if($uname) {
- my $listing=reply('ls2:'.$dirRoot.'/'.$uri,
- homeserver($uname,$udom));
+ my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
+ &homeserver($uname,$udom));
my @listing_results;
if ($listing eq 'unknown_cmd') {
- $listing=reply('ls:'.$dirRoot.'/'.$uri,
- homeserver($uname,$udom));
+ $listing = &reply('ls:'.$dirRoot.'/'.$uri,
+ &homeserver($uname,$udom));
@listing_results = split(/:/,$listing);
} else {
@listing_results = map { &unescape($_); } split(/:/,$listing);
}
return @listing_results;
} elsif(!defined($alternateDirectoryRoot)) {
- my $tryserver;
- my %allusers=();
- foreach $tryserver (keys %libserv) {
+ my %allusers;
+ foreach my $tryserver (keys(%libserv)) {
if($hostdom{$tryserver} eq $udom) {
- my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
- $udom, $tryserver);
+ my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
+ $udom, $tryserver);
my @listing_results;
if ($listing eq 'unknown_cmd') {
- $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
- $udom, $tryserver);
+ $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
+ $udom, $tryserver);
@listing_results = split(/:/,$listing);
} else {
@listing_results =
@@ -5268,40 +5430,36 @@ sub dirlist {
if ($listing_results[0] ne 'no_such_dir' &&
$listing_results[0] ne 'empty' &&
$listing_results[0] ne 'con_lost') {
- foreach (@listing_results) {
- my ($entry,@stat)=split(/&/,$_);
- $allusers{$entry}=1;
+ foreach my $line (@listing_results) {
+ my ($entry) = split(/&/,$line,2);
+ $allusers{$entry} = 1;
}
}
}
}
my $alluserstr='';
- foreach (sort keys %allusers) {
- $alluserstr.=$_.'&user:';
+ foreach my $user (sort(keys(%allusers))) {
+ $alluserstr.=$user.'&user:';
}
$alluserstr=~s/:$//;
return split(/:/,$alluserstr);
} else {
- my @emptyResults = ();
- push(@emptyResults, 'missing user name');
- return split(':',@emptyResults);
+ return ('missing user name');
}
} elsif(!defined($alternateDirectoryRoot)) {
my $tryserver;
my %alldom=();
- foreach $tryserver (keys %libserv) {
+ foreach $tryserver (keys(%libserv)) {
$alldom{$hostdom{$tryserver}}=1;
}
my $alldomstr='';
- foreach (sort keys %alldom) {
- $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';
+ foreach my $domain (sort(keys(%alldom))) {
+ $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
}
$alldomstr=~s/:$//;
return split(/:/,$alldomstr);
} else {
- my @emptyResults = ();
- push(@emptyResults, 'missing domain');
- return split(':',@emptyResults);
+ return ('missing domain');
}
}
@@ -5319,8 +5477,8 @@ sub dirlist {
##
sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;
- $studentDomain=~s/\W//g;
- $studentName=~s/\W//g;
+ $studentDomain = &LONCAPA::clean_domain($studentDomain);
+ $studentName = &LONCAPA::clean_username($studentName);
my $subdir=$studentName.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$studentDomain/$subdir/$studentName";
@@ -5343,13 +5501,13 @@ sub stat_file {
my ($udom,$uname,$file,$dir);
if ($uri =~ m-^/(uploaded|editupload)/-) {
($udom,$uname,$file) =
- ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-);
+ ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
$file = 'userfiles/'.$file;
$dir = &propath($udom,$uname);
}
if ($uri =~ m-^/res/-) {
($udom,$uname) =
- ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-);
+ ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
$file = $uri;
}
@@ -5930,7 +6088,7 @@ sub metadata {
(($uri =~ m|^/*adm/|) &&
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
- ($uri =~ m|home/[^/]+/public_html/|)) {
+ ($uri =~ m|home/$match_username/public_html/|)) {
return undef;
}
my $filename=$uri;
@@ -6297,13 +6455,13 @@ sub symbverify {
}
if ($ids) {
# ------------------------------------------------------------------- Has ID(s)
- foreach (split(/\,/,$ids)) {
- my ($mapid,$resid)=split(/\./,$_);
+ foreach my $id (split(/\,/,$ids)) {
+ my ($mapid,$resid)=split(/\./,$id);
if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {
if (($env{'request.role.adv'}) ||
- $bighash{'encrypted_'.$_} eq $env{'request.enc'}) {
+ $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
$okay=1;
}
}
@@ -6446,10 +6604,10 @@ sub symbread {
} elsif (!$donotrecurse) {
# ------------------------------------------ There is more than one possibility
my $realpossible=0;
- foreach (@possibilities) {
- my $file=$bighash{'src_'.$_};
+ foreach my $id (@possibilities) {
+ my $file=$bighash{'src_'.$id};
if (&allowed('bre',$file)) {
- my ($mapid,$resid)=split(/\./,$_);
+ my ($mapid,$resid)=split(/\./,$id);
if ($bighash{'map_type_'.$mapid} ne 'page') {
$realpossible++;
$syval=&encode_symb($bighash{'map_id_'.$mapid},
@@ -6590,6 +6748,7 @@ sub rndseed {
if (!$domain) { $domain=$wdomain; }
if (!$username) { $username=$wusername }
my $which=&get_rand_alg();
+
if (defined(&getCODE())) {
if ($which eq '64bit5') {
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
@@ -6647,7 +6806,6 @@ sub rndseed_64bit {
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
#&logthis("rndseed :$num:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
- if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";
}
}
@@ -6670,6 +6828,7 @@ sub rndseed_64bit2 {
my $num2=$nameseed+$domainseed+$courseseed;
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
#&logthis("rndseed :$num:$symb");
+ if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";
}
}
@@ -6907,7 +7066,7 @@ sub repcopy_userfile {
if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
my ($cdom,$cnum,$filename) =
- ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
+ ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
my ($info,$rtncode);
my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {
@@ -7008,7 +7167,7 @@ sub readfile {
my $fh;
open($fh,"<$file");
my $a='';
- while (<$fh>) { $a .=$_; }
+ while (my $line = <$fh>) { $a .= $line; }
return $a;
}
@@ -7024,12 +7183,12 @@ sub filelocation {
if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
- } elsif ($file=~m:^/home/[^/]*/public_html/:) {
+ } elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference
$location = $file;
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=
- ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);
+ ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
my $home=&homeserver($uname,$udom);
my $is_me=0;
my @ids=¤t_machine_ids();
@@ -7066,10 +7225,10 @@ sub hreflocation {
}
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
- } elsif ($file=~m-/home/(\w+)/public_html/-) {
- $file=~s-^/home/(\w+)/public_html/-/~$1/-;
+ } elsif ($file=~m-/home/($match_username)/public_html/-) {
+ $file=~s-^/home/($match_username)/public_html/-/~$1/-;
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
- $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/
+ $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;
}
return $file;
@@ -7219,12 +7378,12 @@ BEGIN {
%domain_auth_arg_def = ();
my $fh;
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
- while (<$fh>) {
- next if (/^(\#|\s*$)/);
+ while (my $line = <$fh>) {
+ next if ($line =~ /^(\#|\s*$)/);
# next if /^\#/;
- chomp;
+ chomp $line;
my ($domain, $domain_description, $def_auth, $def_auth_arg,
- $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);
+ $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;
@@ -7554,6 +7713,13 @@ B<delenv($regexp)>: removes all items fr
environment file that matches the regular expression in $regexp. The
values are also delted from the current processes %env.
+=item * get_env_multiple($name)
+
+gets $name from the %env hash, it seemlessly handles the cases where multiple
+values may be defined and end up as an array ref.
+
+returns an array of values
+
=back
=head2 User Information
@@ -7616,8 +7782,7 @@ passed in @what from the requested user'
=item *
-allowed($priv,$uri) : check for a user privilege; returns codes for allowed
-actions
+allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
F: full access
U,I,K: authentication modes (cxx only)
'': forbidden
@@ -8057,6 +8222,15 @@ reference filled in from namesp (encrypt
log($udom,$name,$home,$message) : write to permanent log for user; use
critical subroutine
+=item *
+
+get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
+reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
+
+=item *
+
+put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional)
+
=back
=head2 Network Status Functions