--- loncom/lonnet/perl/lonnet.pm 2006/11/10 02:04:31 1.802
+++ loncom/lonnet/perl/lonnet.pm 2007/01/02 17:54:08 1.819
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.802 2006/11/10 02:04:31 raeburn Exp $
+# $Id: lonnet.pm,v 1.819 2007/01/02 17:54:08 www 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;
@@ -588,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");
@@ -694,6 +693,53 @@ sub idput {
}
}
+# ------------------------------------------- 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");
+ }
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -827,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);
@@ -858,14 +919,13 @@ 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 my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
- &homeserver($unam,$udom)))) {
- my ($key,$value)=split(/\=/,$line,2);
- $key=&unescape($key);
+ $courseid = &courseid_to_courseurl($courseid);
+ my %roleshash = &dump('roles',$udom,$unam,$courseid);
+ foreach my $key (keys(%roleshash)) {
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }
- my ($dummy,$end,$start)=split(/\_/,&unescape($value));
+ my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
my $now=time;
if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;
@@ -1728,7 +1788,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'};
@@ -1749,7 +1810,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};
@@ -2688,6 +2749,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'})) {
@@ -2763,8 +2825,8 @@ sub rolesinit {
$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;
@@ -2843,7 +2905,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;
}
}
@@ -2874,7 +2936,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;
@@ -2999,6 +3061,7 @@ sub getkeys {
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
my @keyarray=();
foreach my $key (split(/\&/,$rep)) {
+ next if ($key =~ /^error: 2 /);
push(@keyarray,&unescape($key));
}
return @keyarray;
@@ -3257,6 +3320,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_/) {
@@ -3332,7 +3411,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;
@@ -3345,7 +3424,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';
@@ -3440,12 +3519,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;
@@ -3465,7 +3544,7 @@ sub is_portfolio_url {
sub is_portfolio_file {
my ($file) = @_;
- if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
+ if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w\/portfolio/)) {
return 1;
}
return;
@@ -3476,9 +3555,10 @@ sub is_portfolio_file {
sub customaccess {
my ($priv,$uri)=@_;
- my ($urole,$urealm)=split(/\./,$env{'request.role'});
- $urealm=~s/^\W//;
- my ($udom,$ucrs,$usec)=split(/\//,$urealm);
+ my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
+ my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
+ $udom = &LONCAPA::clean_domain($udom);
+ $ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;
foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
my ($effect,$realm,$role)=split(/\:/,$right);
@@ -3509,12 +3589,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)$}))
@@ -3527,7 +3616,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.
@@ -3803,6 +3899,8 @@ sub allowed {
unless ($env{'request.course.id'}) {
if ($thisallowed eq 'A') {
return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
} else {
return '1';
}
@@ -3870,6 +3968,8 @@ sub allowed {
if ($thisallowed eq 'A') {
return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
}
return 'F';
}
@@ -3996,6 +4096,18 @@ sub log_query {
return get_query_reply($queryid);
}
+# -------------------------- Update MySQL table for portfolio file
+
+sub update_portfolio_table {
+ my ($uname,$udom,$file_name,$query,$group) = @_;
+ my $homeserver = &homeserver($uname,$udom);
+ my $queryid=
+ &reply("querysend:".$query.':'.&escape($uname.':'.$udom).':'.
+ &escape($file_name).':'.&escape($group),$homeserver);
+ my $reply = &get_query_reply($queryid);
+ return $reply;
+}
+
# ------- Request retrieval of institutional classlists for course(s)
sub fetch_enrollment_query {
@@ -4299,8 +4411,8 @@ sub auto_instcode_defaults {
$returnhash->{&unescape($name)}=&unescape($value);
}
}
+ $ok_response = 1;
}
- $ok_response = 1;
}
if ($ok_response) {
return 'ok';
@@ -4320,8 +4432,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 {
@@ -4329,6 +4441,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;
@@ -4352,7 +4495,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; }
@@ -4373,8 +4516,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);
@@ -4382,38 +4523,34 @@ sub get_users_groups {
@usersgroups = split(/:/,$grouplist);
} else {
$grouplist = '';
- my %roleshash = &dump('roles',$udom,$uname,$courseid);
- my ($tmp) = keys(%roleshash);
- if ($tmp=~/^error:/) {
- &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
- } else {
- my $access_end = $env{'course.'.$courseid.
- '.default_enrollment_end_date'};
- my $now = time;
- foreach my $key (keys(%roleshash)) {
- if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
- my $group = $1;
- if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
- my $start = $2;
- my $end = $1;
- if ($start == -1) { next; } # deleted from group
- if (($start!=0) && ($start>$now)) { next; }
- if (($end!=0) && ($end<$now)) {
- if ($access_end && $access_end < $now) {
- if ($access_end - $end < 86400) {
- push(@usersgroups,$group);
- }
+ my $courseurl = &courseid_to_courseurl($courseid);
+ my %roleshash = &dump('roles',$udom,$uname,$courseurl);
+ my $access_end = $env{'course.'.$courseid.
+ '.default_enrollment_end_date'};
+ my $now = time;
+ foreach my $key (keys(%roleshash)) {
+ if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
+ my $group = $1;
+ if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
+ my $start = $2;
+ my $end = $1;
+ if ($start == -1) { next; } # deleted from group
+ if (($start!=0) && ($start>$now)) { next; }
+ if (($end!=0) && ($end<$now)) {
+ if ($access_end && $access_end < $now) {
+ if ($access_end - $end < 86400) {
+ push(@usersgroups,$group);
}
- next;
}
- push(@usersgroups,$group);
+ next;
}
+ push(@usersgroups,$group);
}
}
- @usersgroups = &sort_course_groups($courseid,@usersgroups);
- $grouplist = join(':',@usersgroups);
- &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
}
+ @usersgroups = &sort_course_groups($courseid,@usersgroups);
+ $grouplist = join(':',@usersgroups);
+ &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
}
return @usersgroups;
}
@@ -4421,8 +4558,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);
}
@@ -4461,7 +4597,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 '.
@@ -4471,7 +4607,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 '.
@@ -4481,7 +4617,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 '.
@@ -4561,8 +4697,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.')'.
@@ -4847,6 +4983,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 {
@@ -5125,6 +5271,15 @@ sub modify_access_controls {
# remove lock
my @del_lock = ($file_name."\0".'locked_access_records');
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
+ my ($file,$group);
+ if (&is_course($domain,$user)) {
+ ($group,$file) = split(/\//,$file_name,2);
+ } else {
+ $file = $file_name;
+ }
+ my $sqlresult =
+ &update_portfolio_table($user,$domain,$file,'portfolio_access',
+ $group);
} else {
$outcome = "error: could not obtain lockfile\n";
}
@@ -5336,8 +5491,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";
@@ -5360,13 +5515,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;
}
@@ -5947,7 +6102,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;
@@ -6607,6 +6762,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);
@@ -6664,7 +6820,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";
}
}
@@ -6687,6 +6842,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";
}
}
@@ -6924,7 +7080,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") {
@@ -7041,12 +7197,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();
@@ -7083,10 +7239,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;
@@ -7640,8 +7796,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
@@ -8081,6 +8236,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