--- loncom/lonnet/perl/lonnet.pm 2006/11/22 19:59:42 1.807
+++ loncom/lonnet/perl/lonnet.pm 2007/01/18 18:21:10 1.827
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.807 2006/11/22 19:59:42 albertel Exp $
+# $Id: lonnet.pm,v 1.827 2007/01/18 18:21:10 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -53,7 +53,6 @@ use Time::HiRes qw( gettimeofday tv_inte
use Cache::Memcached;
use Digest::MD5;
use Math::Random;
-use lib '/home/httpd/lib/perl';
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
@@ -190,7 +189,6 @@ sub subreply {
sub reply {
my ($cmd,$server)=@_;
- &logthis("$cmd $server");
unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
@@ -879,6 +877,25 @@ sub devalidate_getsection_cache {
&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;
@@ -902,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;
@@ -1685,6 +1701,12 @@ sub removeuserfile {
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
my $metafile = $fname.'.meta';
my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
+ my $url = "/uploaded/$docudom/$docuname/$fname";
+ my ($file,$group) = (&parse_portfolio_url($url))[3,4];
+ my $sqlresult =
+ &update_portfolio_table($docuname,$docudom,$file,
+ 'portfolio_metadata',$group,
+ 'delete');
}
}
return $result;
@@ -1707,6 +1729,12 @@ sub renameuserfile {
my $newmeta = $new.'.meta';
my $metaresult =
&renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
+ my $url = "/uploaded/$docudom/$docuname/$old";
+ my ($file,$group) = (&parse_portfolio_url($url))[3,4];
+ my $sqlresult =
+ &update_portfolio_table($docuname,$docudom,$file,
+ 'portfolio_metadata',$group,
+ 'delete');
}
}
return $result;
@@ -1773,7 +1801,7 @@ sub flushcourselogs {
if ($entry =~ /___count$/) {
my ($dom,$name);
($dom,$name,undef)=
- ($entry=~m{___($match_domain)/($match_username)/(.*)___count$});
+ ($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
if (! defined($dom) || $dom eq '' ||
! defined($name) || $name eq '') {
my $cid = $env{'request.course.id'};
@@ -1794,7 +1822,7 @@ sub flushcourselogs {
}
}
} else {
- my ($dom,$name) = ($entry=~m{___($match_domain)/($match_username)/(.*)___(\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};
@@ -2733,6 +2761,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'})) {
@@ -2888,7 +2917,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|(/$match_domain/$match_username)/([^/]+)$|);
+ my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
$$allgroups{$course}{$group} .=':'.$group_privs;
}
}
@@ -2919,7 +2948,7 @@ sub set_userprivs {
if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);
- if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_username)(/?\w*)-) {
+ if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
$trole = $1;
$area = $2;
$sec = $3;
@@ -3031,7 +3060,23 @@ sub dump {
sub dumpstore {
my ($namespace,$udomain,$uname,$regexp,$range)=@_;
- return &dump($namespace,$udomain,$uname,$regexp,$range);
+ if (!$udomain) { $udomain=$env{'user.domain'}; }
+ if (!$uname) { $uname=$env{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ if ($regexp) {
+ $regexp=&escape($regexp);
+ } else {
+ $regexp='.';
+ }
+ my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
+ my @pairs=split(/\&/,$rep);
+ my %returnhash=();
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
+ return %returnhash;
}
# -------------------------------------------------------------- keys interface
@@ -3044,6 +3089,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;
@@ -3064,7 +3110,7 @@ sub currentdump {
if ($rep eq "unknown_cmd") {
# an old lond will not know currentdump
# Do a dump and make it look like a currentdump
- my @tmp = &dump($courseid,$sdom,$sname,'.');
+ my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
return if ($tmp[0] =~ /^(error:|no_such_host)/);
my %hash = @tmp;
@tmp=();
@@ -3089,6 +3135,8 @@ sub convert_dump_to_currentdump{
# we might run in to problems with parameter names =~ /^v\./
while (my ($key,$value) = each(%hash)) {
my ($v,$symb,$param) = split(/:/,$key);
+ $symb = &unescape($symb);
+ $param = &unescape($param);
next if ($v eq 'version' || $symb eq 'keys');
next if (exists($returnhash{$symb}) &&
exists($returnhash{$symb}->{$param}) &&
@@ -3302,6 +3350,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_/) {
@@ -3377,7 +3441,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)\./($match_domain)/($match_username)/?([^/]*)$-) {
+ 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;
@@ -3390,7 +3454,7 @@ sub get_portfolio_access {
}
$allroles{$cid}{$1}{$sec} = $env{$envkey};
}
- } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_username)/?([^/]*)$-) {
+ } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;
if ($4 eq '') {
$sec = 'none';
@@ -3485,12 +3549,12 @@ sub parse_portfolio_url {
my ($type,$udom,$unum,$group,$file_name);
- if ($url =~ m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) {
+ if ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
$type = 1;
$udom = $1;
$unum = $2;
$file_name = $3;
- } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_username)/groups/([^/]+)/portfolio/(.+)$-) {
+ } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
$type = 2;
$udom = $1;
$unum = $2;
@@ -3510,7 +3574,7 @@ sub is_portfolio_url {
sub is_portfolio_file {
my ($file) = @_;
- if (($file =~ /^portfolio/) || ($file =~ /^groups\/$match_username\/portfolio/)) {
+ if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
return 1;
}
return;
@@ -3522,7 +3586,7 @@ sub is_portfolio_file {
sub customaccess {
my ($priv,$uri)=@_;
my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
- my ($udom,$ucrs,$usec)=split(/\//,$urealm);
+ my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
$udom = &LONCAPA::clean_domain($udom);
$ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;
@@ -3555,12 +3619,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)$}))
@@ -3573,7 +3646,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.
@@ -3849,6 +3929,8 @@ sub allowed {
unless ($env{'request.course.id'}) {
if ($thisallowed eq 'A') {
return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
} else {
return '1';
}
@@ -3916,6 +3998,8 @@ sub allowed {
if ($thisallowed eq 'A') {
return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
}
return 'F';
}
@@ -4042,6 +4126,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,$action) = @_;
+ my $homeserver = &homeserver($uname,$udom);
+ my $queryid=
+ &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
+ ':'.&escape($file_name).':'.$action,$homeserver);
+ my $reply = &get_query_reply($queryid);
+ return $reply;
+}
+
# ------- Request retrieval of institutional classlists for course(s)
sub fetch_enrollment_query {
@@ -4366,13 +4462,8 @@ sub auto_validate_class_sec {
# ------------------------------------------------------- Course Group routines
sub get_coursegroups {
- my ($cdom,$cnum,$group) = @_;
- return(&dump('coursegroups',$cdom,$cnum,$group));
-}
-
-sub get_deleted_groups {
- my ($cdom,$cnum,$group) = @_;
- return(&dump('deleted_groups',$cdom,$cnum,$group));
+ my ($cdom,$cnum,$group,$namespace) = @_;
+ return(&dump($namespace,$cdom,$cnum,$group));
}
sub modify_coursegroup {
@@ -4380,18 +4471,26 @@ sub modify_coursegroup {
return(&put('coursegroups',$groupsettings,$cdom,$cnum));
}
-sub delete_coursegroup {
- my ($cdom,$cnum,$group) = @_;
- my %curr_group = &get_coursegroups($cdom,$cnum,$group);
+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('deleted_groups',\%savedsettings,$cdom,$cnum);
+ my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
my $deloutcome;
if ($result eq 'ok') {
- $deloutcome = &del('coursegroups',[$group],$cdom,$cnum);
+ $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
} else {
return ('write error',$result);
}
@@ -4426,7 +4525,7 @@ sub get_active_groups {
my $now = time;
my %groups = ();
foreach my $key (keys(%env)) {
- if ($key =~ m-user\.role\.gr\./($match_domain)/($match_username)/(\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; }
@@ -4454,38 +4553,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;
}
@@ -4532,7 +4627,7 @@ sub assignrole {
my $mrole;
if ($role =~ /^cr\//) {
my $cwosec=$url;
- $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$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 '.
@@ -4542,8 +4637,7 @@ sub assignrole {
$mrole='cr';
} elsif ($role =~ /^gr\//) {
my $cwogrp=$url;
- $cwogrp=~s{^/($match_domain)/($match_username)/.*}
- {$1/$2}x;
+ $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
unless (&allowed('mdg',$cwogrp)) {
&logthis('Refused group assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -4553,7 +4647,7 @@ sub assignrole {
$mrole='gr';
} else {
my $cwosec=$url;
- $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$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 '.
@@ -4919,6 +5013,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 {
@@ -5197,12 +5301,68 @@ 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";
}
return ($outcome,$deloutcome,\%new_values,\%translation);
}
+sub make_public_indefinitely {
+ my ($requrl) = @_;
+ my $now = time;
+ my $action = 'activate';
+ my $aclnum = 0;
+ if (&is_portfolio_url($requrl)) {
+ my (undef,$udom,$unum,$file_name,$group) =
+ &parse_portfolio_url($requrl);
+ my $current_perms = &get_portfile_permissions($udom,$unum);
+ my %access_controls = &get_access_controls($current_perms,
+ $group,$file_name);
+ foreach my $key (keys(%{$access_controls{$file_name}})) {
+ my ($num,$scope,$end,$start) =
+ ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
+ if ($scope eq 'public') {
+ if ($start <= $now && $end == 0) {
+ $action = 'none';
+ } else {
+ $action = 'update';
+ $aclnum = $num;
+ }
+ last;
+ }
+ }
+ if ($action eq 'none') {
+ return 'ok';
+ } else {
+ my %changes;
+ my $newend = 0;
+ my $newstart = $now;
+ my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
+ $changes{$action}{$newkey} = {
+ type => 'public',
+ time => {
+ start => $newstart,
+ end => $newend,
+ },
+ };
+ my ($outcome,$deloutcome,$new_values,$translation) =
+ &modify_access_controls($file_name,\%changes,$udom,$unum);
+ return $outcome;
+ }
+ } else {
+ return 'invalid';
+ }
+}
+
#------------------------------------------------------Get Marked as Read Only
sub get_marked_as_readonly {
@@ -5432,7 +5592,7 @@ sub stat_file {
my ($udom,$uname,$file,$dir);
if ($uri =~ m-^/(uploaded|editupload)/-) {
($udom,$uname,$file) =
- ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_username)/?(.*)-);
+ ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
$file = 'userfiles/'.$file;
$dir = &propath($udom,$uname);
}
@@ -6997,7 +7157,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/+($match_domain)/+($match_username)/+(.*)|);
+ ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
my ($info,$rtncode);
my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {
@@ -7030,6 +7190,10 @@ sub repcopy_userfile {
if ($lwpresp ne 'ok') {
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',&tokenwrapper($uri));
+ # FIXME, right reads everything into memory then writes it out
+ # doing something like
+ # my $response=$ua->request($request,$file);
+ # would make this write directly to disk
my $response=$ua->request($request);
if ($response->is_success()) {
$info=$response->content;
@@ -7119,7 +7283,7 @@ sub filelocation {
$location = $file;
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=
- ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_username)/+(.*)$-);
+ ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
my $home=&homeserver($uname,$udom);
my $is_me=0;
my @ids=¤t_machine_ids();
@@ -7159,7 +7323,7 @@ sub hreflocation {
} 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/($match_domain)/./././($match_username)/userfiles/
+ $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;
}
return $file;
@@ -7189,6 +7353,29 @@ sub current_machine_ids {
return @ids;
}
+sub additional_machine_domains {
+ my @domains;
+ open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
+ while( my $line = <$fh>) {
+ $line =~ s/\s//g;
+ push(@domains,$line);
+ }
+ return @domains;
+}
+
+sub default_login_domain {
+ my $domain = $perlvar{'lonDefDomain'};
+ my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
+ foreach my $posdom (¤t_machine_domains(),
+ &additional_machine_domains()) {
+ if (lc($posdom) eq lc($testdomain)) {
+ $domain=$posdom;
+ last;
+ }
+ }
+ return $domain;
+}
+
# ------------------------------------------------------------- Declutters URLs
sub declutter {
@@ -7361,7 +7548,7 @@ sub get_iphost {
if (!exists($name_to_ip{$name})) {
$ip = gethostbyname($name);
if (!$ip || length($ip) ne 4) {
- &logthis("Skipping host $id name $name no IP found\n");
+ &logthis("Skipping host $id name $name no IP found");
next;
}
$ip=inet_ntoa($ip);
@@ -7713,8 +7900,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