--- loncom/lonnet/perl/lonnet.pm 2024/02/28 05:40:11 1.1172.2.146.2.19 +++ loncom/lonnet/perl/lonnet.pm 2023/11/18 14:33:07 1.1519 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.146.2.19 2024/02/28 05:40:11 raeburn Exp $ +# $Id: lonnet.pm,v 1.1519 2023/11/18 14:33:07 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,11 +71,12 @@ delayed. package Apache::lonnet; use strict; -use LWP::UserAgent(); use HTTP::Date; use Image::Magick; use CGI::Cookie; +use Encode; + use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease %managerstab $passwdmin); @@ -101,6 +102,7 @@ use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; use LONCAPA::lonmetadata; use LONCAPA::Lond; +use LONCAPA::LWPReq; use LONCAPA::transliterate; use File::Copy; @@ -113,6 +115,7 @@ require Exporter; our @ISA = qw (Exporter); our @EXPORT = qw(%env); + # ------------------------------------ Logging (parameters, docs, slots, roles) { my $logid; @@ -128,19 +131,19 @@ our @EXPORT = qw(%env); my $now = time(); my $id=$now.'00000'.$$.'00000'.$logid; my $ip = &get_requestor_ip(); - my $logentry = { - $id => { - 'exe_uname' => $env{'user.name'}, - 'exe_udom' => $env{'user.domain'}, - 'exe_time' => $now, - 'exe_ip' => $ip, - 'delflag' => $delflag, - 'logentry' => $storehash, - 'uname' => $uname, - 'udom' => $udom, - } + my $logentry = { + $id => { + 'exe_uname' => $env{'user.name'}, + 'exe_udom' => $env{'user.domain'}, + 'exe_time' => $now, + 'exe_ip' => $ip, + 'delflag' => $delflag, + 'logentry' => $storehash, + 'uname' => $uname, + 'udom' => $udom, + } }; - return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); + return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); } } @@ -185,7 +188,7 @@ sub create_connection { Type => SOCK_STREAM, Timeout => 10); return 0 if (!$client); - print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n"); + print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n"); my $result = <$client>; chomp($result); return 1 if ($result eq 'done'); @@ -230,6 +233,54 @@ sub get_server_distarch { return; } +sub get_servercerts_info { + my ($lonhost,$hostname,$context) = @_; + return if ($lonhost eq ''); + if ($hostname eq '') { + $hostname = &hostname($lonhost); + } + return if ($hostname eq ''); + my ($rep,$uselocal); + if ($context eq 'install') { + $uselocal = 1; + } elsif (grep { $_ eq $lonhost } ¤t_machine_ids()) { + $uselocal = 1; + } + if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) { + my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; + if ($distro eq '') { + $uselocal = 0; + } elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) { + if ($1 < 6) { + $uselocal = 0; + } + } elsif ($distro =~ /^(?:sles)(\d+)$/) { + if ($1 < 12) { + $uselocal = 0; + } + } + } + if ($uselocal) { + $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname); + } else { + $rep=&reply('servercerts',$lonhost); + } + my ($result,%returnhash); + if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || + ($rep eq 'unknown_cmd')) { + $result = $rep; + } else { + $result = 'ok'; + my @pairs=split(/\&/,$rep); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + my $what = &unescape($key); + $returnhash{$what}=&thaw_unescape($value); + } + } + return ($result,\%returnhash); +} + sub get_server_loncaparev { my ($dom,$lonhost,$ignore_cache,$caller) = @_; if (defined($lonhost)) { @@ -264,14 +315,12 @@ sub get_server_loncaparev { $answer = &reply('serverloncaparev',$lonhost); if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { if ($caller eq 'loncron') { - my $ua=new LWP::UserAgent; - $ua->timeout(4); my $hostname = &hostname($lonhost); my $protocol = $protocol{$lonhost}; $protocol = 'http' if ($protocol ne 'https'); my $url = $protocol.'://'.$hostname.'/adm/about.html'; my $request=new HTTP::Request('GET',$url); - my $response=$ua->request($request); + my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1); unless ($response->is_error()) { my $content = $response->content; if ($content =~ /
VERSION\:\s*([\w.\-]+)<\/p>/) {
@@ -362,7 +411,8 @@ sub remote_devalidate_cache {
my $items;
return unless (ref($cachekeys) eq 'ARRAY');
my $cachestr = join('&',@{$cachekeys});
- return &reply('devalidatecache:'.&escape($cachestr),$lonhost);
+ my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
+ return $response;
}
sub sign_lti {
@@ -451,7 +501,7 @@ sub subreply {
} else {
&create_connection(&hostname($server),$server);
}
- sleep(0.1); # Try again later if failed connection.
+ sleep(0.1); # Try again later if failed connection.
}
my $answer;
if ($client) {
@@ -525,7 +575,7 @@ sub reconlonc {
&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;
sleep 1;
- } else {
+ } else {
&logthis(
"WARNING:".
" lonc at pid $loncpid not responding, giving up");
@@ -720,7 +770,7 @@ sub check_for_valid_session {
}
}
if (!-e "$lonidsdir/$handle.id") {
- if ((ref($domref)) && ($name eq 'lonID') &&
+ if ((ref($domref)) && ($name eq 'lonID') &&
($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
@@ -992,9 +1042,9 @@ sub spareserver {
: $userloadpercent;
my ($uint_dom,$remotesessions);
if (($udom ne '') && (&domain($udom) ne '')) {
- my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
- $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
- my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
+ my $uprimary_id = &domain($udom,'primary');
+ $uint_dom = &internet_dom($uprimary_id);
+ my %udomdefaults = &get_domain_defaults($udom);
$remotesessions = $udomdefaults{'remotesessions'};
}
my $spareshash = &this_host_spares($udom);
@@ -1030,7 +1080,7 @@ sub spareserver {
if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};
}
- my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);
+ my $alias = &use_proxy_alias($r,$spare_server);
$hostname = $alias if ($alias ne '');
$spare_server = $protocol.'://'.$hostname;
}
@@ -1111,7 +1161,6 @@ sub delusersession {
return;
}
-
# check if user's browser sent load balancer cookie and server still has session
# and is not overloaded.
sub check_for_balancer_cookie {
@@ -1219,7 +1268,7 @@ sub choose_server {
unless (defined($cached)) {
my $cachetime = 60*60*24;
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
+ &get_dom('configuration',['loadbalancing'],$udom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
$cachetime);
@@ -1227,12 +1276,12 @@ sub choose_server {
}
}
foreach my $lonhost (keys(%servers)) {
- my $loginvia;
if ($skiploadbal) {
if (ref($balancers) eq 'HASH') {
next if (exists($balancers->{$lonhost}));
}
}
+ my $loginvia;
if ($checkloginvia) {
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
if ($loginvia) {
@@ -1412,7 +1461,7 @@ sub can_switchserver {
sub can_host_session {
my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
my $canhost = 1;
- my $host_idn = &Apache::lonnet::internet_dom($lonhost);
+ my $host_idn = &internet_dom($lonhost);
if (ref($remotesessions) eq 'HASH') {
if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
@@ -1448,8 +1497,8 @@ sub can_host_session {
}
if ($canhost) {
if (ref($hostedsessions) eq 'HASH') {
- my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
- my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
+ my $uprimary_id = &domain($udom,'primary');
+ my $uint_dom = &internet_dom($uprimary_id);
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
if (($uint_dom ne '') &&
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
@@ -1541,7 +1590,7 @@ sub spares_for_offload {
} else {
my $cachetime = 60*60*24;
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use);
+ &get_dom('configuration',['usersessions'],$dom_in_use);
if (ref($domconfig{'usersessions'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
@@ -1590,14 +1639,14 @@ sub get_lonbalancer_config {
sub check_loadbalancing {
my ($uname,$udom,$caller) = @_;
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
- $rule_in_effect,$offloadto,$otherserver,$setcookie);
+ $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);
my $lonhost = $perlvar{'lonHostID'};
my @hosts = ¤t_machine_ids();
- my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
- my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
- my $intdom = &Apache::lonnet::internet_dom($lonhost);
+ my $uprimary_id = &domain($udom,'primary');
+ my $uintdom = &internet_dom($uprimary_id);
+ my $intdom = &internet_dom($lonhost);
my $serverhomedom = &host_domain($lonhost);
- my $domneedscache;
+ my $domneedscache;
my $cachetime = 60*60*24;
if (($uintdom ne '') && ($uintdom eq $intdom)) {
@@ -1609,7 +1658,7 @@ sub check_loadbalancing {
my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
unless (defined($cached)) {
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
+ &get_dom('configuration',['loadbalancing'],$dom_in_use);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
} else {
@@ -1617,7 +1666,7 @@ sub check_loadbalancing {
}
}
if (ref($result) eq 'HASH') {
- ($is_balancer,$currtargets,$currrules,$setcookie) =
+ ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
&check_balancer_result($result,@hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
@@ -1670,7 +1719,7 @@ sub check_loadbalancing {
($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
unless (defined($cached)) {
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
+ &get_dom('configuration',['loadbalancing'],$serverhomedom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);
} else {
@@ -1678,7 +1727,7 @@ sub check_loadbalancing {
}
}
if (ref($result) eq 'HASH') {
- ($is_balancer,$currtargets,$currrules,$setcookie) =
+ ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
&check_balancer_result($result,@hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
@@ -1754,12 +1803,12 @@ sub check_loadbalancing {
if (($is_balancer) && (!$homeintdom)) {
undef($setcookie);
}
- return ($is_balancer,$otherserver,$setcookie);
+ return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers);
}
sub check_balancer_result {
my ($result,@hosts) = @_;
- my ($is_balancer,$currtargets,$currrules,$setcookie);
+ my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
if (ref($result) eq 'HASH') {
if ($result->{'lonhost'} ne '') {
my $currbalancer = $result->{'lonhost'};
@@ -1768,20 +1817,24 @@ sub check_balancer_result {
$currtargets = $result->{'targets'};
$currrules = $result->{'rules'};
}
+ $dom_balancers = $currbalancer;
} else {
- foreach my $key (keys(%{$result})) {
- if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
- (ref($result->{$key}) eq 'HASH')) {
- $is_balancer = 1;
- $currrules = $result->{$key}{'rules'};
- $currtargets = $result->{$key}{'targets'};
- $setcookie = $result->{$key}{'cookie'};
- last;
+ if (keys(%{$result})) {
+ foreach my $key (keys(%{$result})) {
+ if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
+ (ref($result->{$key}) eq 'HASH')) {
+ $is_balancer = 1;
+ $currrules = $result->{$key}{'rules'};
+ $currtargets = $result->{$key}{'targets'};
+ $setcookie = $result->{$key}{'cookie'};
+ last;
+ }
}
+ $dom_balancers = join(',',sort(keys(%{$result})));
}
}
}
- return ($is_balancer,$currtargets,$currrules,$setcookie);
+ return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
}
sub get_loadbalancer_targets {
@@ -1799,7 +1852,7 @@ sub get_loadbalancer_targets {
}
} elsif ($rule_in_effect eq 'externalbalancer') {
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
+ &get_dom('configuration',['loadbalancing'],$udom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
@@ -1853,6 +1906,101 @@ sub internet_dom_servers {
return %uniqservers;
}
+sub trusted_domains {
+ my ($cmdtype,$calldom) = @_;
+ my ($trusted,$untrusted);
+ if (&domain($calldom) eq '') {
+ return ($trusted,$untrusted);
+ }
+ unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) {
+ return ($trusted,$untrusted);
+ }
+ my $callprimary = &domain($calldom,'primary');
+ my $intcalldom = &internet_dom($callprimary);
+ if ($intcalldom eq '') {
+ return ($trusted,$untrusted);
+ }
+
+ my ($trustconfig,$cached)=&is_cached_new('trust',$calldom);
+ unless (defined($cached)) {
+ my %domconfig = &get_dom('configuration',['trust'],$calldom);
+ &do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
+ $trustconfig = $domconfig{'trust'};
+ }
+ if (ref($trustconfig)) {
+ my (%possexc,%possinc,@allexc,@allinc);
+ if (ref($trustconfig->{$cmdtype}) eq 'HASH') {
+ if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') {
+ map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}};
+ }
+ if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
+ $possinc{$intcalldom} = 1;
+ map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
+ }
+ }
+ if (keys(%possexc)) {
+ if (keys(%possinc)) {
+ foreach my $key (sort(keys(%possexc))) {
+ next if ($key eq $intcalldom);
+ unless ($possinc{$key}) {
+ push(@allexc,$key);
+ }
+ }
+ } else {
+ @allexc = sort(keys(%possexc));
+ }
+ }
+ if (keys(%possinc)) {
+ $possinc{$intcalldom} = 1;
+ @allinc = sort(keys(%possinc));
+ }
+ if ((@allexc > 0) || (@allinc > 0)) {
+ my %doms_by_intdom;
+ my %allintdoms = &all_host_intdom();
+ my %alldoms = &all_host_domain();
+ foreach my $key (%allintdoms) {
+ if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') {
+ unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) {
+ push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key});
+ }
+ } else {
+ $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}];
+ }
+ }
+ foreach my $exc (@allexc) {
+ if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
+ push(@{$untrusted},@{$doms_by_intdom{$exc}});
+ }
+ }
+ foreach my $inc (@allinc) {
+ if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
+ push(@{$trusted},@{$doms_by_intdom{$inc}});
+ }
+ }
+ }
+ }
+ return ($trusted,$untrusted);
+}
+
+sub will_trust {
+ my ($cmdtype,$domain,$possdom) = @_;
+ return 1 if ($domain eq $possdom);
+ my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom);
+ my $willtrust;
+ if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) {
+ if (grep(/^\Q$domain\E$/,@{$trustedref})) {
+ $willtrust = 1;
+ }
+ } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) {
+ unless (grep(/^\Q$domain\E$/,@{$untrustedref})) {
+ $willtrust = 1;
+ }
+ } else {
+ $willtrust = 1;
+ }
+ return $willtrust;
+}
+
# ---------------------- Find the homebase for a user from domain's lib servers
my %homecache;
@@ -1878,17 +2026,33 @@ sub homeserver {
return 'no_host';
}
-# ------------------------------------- Find the usernames behind a list of IDs
+# ----- Find the usernames behind a list of student/employee IDs or clicker IDs
sub idget {
- my ($udom,@ids)=@_;
+ my ($udom,$idsref,$namespace)=@_;
my %returnhash=();
+ my @ids=();
+ if (ref($idsref) eq 'ARRAY') {
+ @ids = @{$idsref};
+ } else {
+ return %returnhash;
+ }
+ if ($namespace eq '') {
+ $namespace = 'ids';
+ }
my %servers = &get_servers($udom,'library');
foreach my $tryserver (keys(%servers)) {
my $idlist=join('&', map { &escape($_); } @ids);
- $idlist=~tr/A-Z/a-z/;
- my $reply=&reply("idget:$udom:".$idlist,$tryserver);
+ if ($namespace eq 'ids') {
+ $idlist=~tr/A-Z/a-z/;
+ }
+ my $reply;
+ if ($namespace eq 'ids') {
+ $reply=&reply("idget:$udom:".$idlist,$tryserver);
+ } else {
+ $reply=&reply("getdom:$udom:$namespace:$idlist",$tryserver);
+ }
my @answer=();
if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
@answer=split(/\&/,$reply);
@@ -1897,9 +2061,9 @@ sub idget {
for ($i=0;$i<=$#ids;$i++) {
if ($answer[$i]) {
$returnhash{$ids[$i]}=&unescape($answer[$i]);
- }
+ }
}
- }
+ }
return %returnhash;
}
@@ -1914,60 +2078,141 @@ sub idrget {
return %returnhash;
}
-# ------------------------------- Store away a list of names and associated IDs
+# Store away a list of names and associated student/employee IDs or clicker IDs
sub idput {
- my ($udom,%ids)=@_;
+ my ($udom,$idsref,$uhom,$namespace)=@_;
my %servers=();
+ my %ids=();
+ my %byid = ();
+ if (ref($idsref) eq 'HASH') {
+ %ids=%{$idsref};
+ }
+ if ($namespace eq '') {
+ $namespace = 'ids';
+ }
foreach my $uname (keys(%ids)) {
&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
- my $uhom=&homeserver($uname,$udom);
+ if ($uhom eq '') {
+ $uhom=&homeserver($uname,$udom);
+ }
if ($uhom ne 'no_host') {
- my $id=&escape($ids{$uname});
- $id=~tr/A-Z/a-z/;
my $esc_unam=&escape($uname);
- if ($servers{$uhom}) {
- $servers{$uhom}.='&'.$id.'='.$esc_unam;
+ if ($namespace eq 'ids') {
+ my $id=&escape($ids{$uname});
+ $id=~tr/A-Z/a-z/;
+ my $esc_unam=&escape($uname);
+ $servers{$uhom}.=$id.'='.$esc_unam.'&';
} else {
- $servers{$uhom}=$id.'='.$esc_unam;
+ my @currids = split(/,/,$ids{$uname});
+ foreach my $id (@currids) {
+ $byid{$uhom}{$id} .= $uname.',';
+ }
+ }
+ }
+ }
+ if ($namespace eq 'clickers') {
+ foreach my $server (keys(%byid)) {
+ if (ref($byid{$server}) eq 'HASH') {
+ foreach my $id (keys(%{$byid{$server}})) {
+ $byid{$server} =~ s/,$//;
+ $servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&';
+ }
}
}
}
foreach my $server (keys(%servers)) {
- &critical('idput:'.$udom.':'.$servers{$server},$server);
+ $servers{$server} =~ s/\&$//;
+ if ($namespace eq 'ids') {
+ &critical('idput:'.$udom.':'.$servers{$server},$server);
+ } else {
+ &critical('updateclickers:'.$udom.':add:'.$servers{$server},$server);
+ }
}
}
-# ---------------------------------------- Delete unwanted IDs from ids.db file
+# ------------- Delete unwanted student/employee IDs or clicker IDs from domain
sub iddel {
- my ($udom,$idshashref,$uhome)=@_;
+ my ($udom,$idshashref,$uhome,$namespace)=@_;
my %result=();
- unless (ref($idshashref) eq 'HASH') {
+ my %ids=();
+ my %byid = ();
+ if (ref($idshashref) eq 'HASH') {
+ %ids=%{$idshashref};
+ } else {
return %result;
}
+ if ($namespace eq '') {
+ $namespace = 'ids';
+ }
my %servers=();
- while (my ($id,$uname) = each(%{$idshashref})) {
- my $uhom;
- if ($uhome) {
- $uhom = $uhome;
- } else {
- $uhom=&homeserver($uname,$udom);
- }
- if ($uhom ne 'no_host') {
- if ($servers{$uhom}) {
+ while (my ($id,$unamestr) = each(%ids)) {
+ if ($namespace eq 'ids') {
+ my $uhom = $uhome;
+ if ($uhom eq '') {
+ $uhom=&homeserver($unamestr,$udom);
+ }
+ if ($uhom ne 'no_host') {
$servers{$uhom}.='&'.&escape($id);
- } else {
- $servers{$uhom}=&escape($id);
+ }
+ } else {
+ my @curritems = split(/,/,$ids{$id});
+ foreach my $uname (@curritems) {
+ my $uhom = $uhome;
+ if ($uhom eq '') {
+ $uhom=&homeserver($uname,$udom);
+ }
+ if ($uhom ne 'no_host') {
+ $byid{$uhom}{$id} .= $uname.',';
+ }
+ }
+ }
+ }
+ if ($namespace eq 'clickers') {
+ foreach my $server (keys(%byid)) {
+ if (ref($byid{$server}) eq 'HASH') {
+ foreach my $id (keys(%{$byid{$server}})) {
+ $byid{$server}{$id} =~ s/,$//;
+ $servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&';
+ }
}
}
}
foreach my $server (keys(%servers)) {
- $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
+ $servers{$server} =~ s/\&$//;
+ if ($namespace eq 'ids') {
+ $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
+ } elsif ($namespace eq 'clickers') {
+ $result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server);
+ }
}
return %result;
}
+# ----- Update clicker ID-to-username look-ups in clickers.db on library server
+
+sub updateclickers {
+ my ($udom,$action,$idshashref,$uhome,$critical) = @_;
+ my %clickers;
+ if (ref($idshashref) eq 'HASH') {
+ %clickers=%{$idshashref};
+ } else {
+ return;
+ }
+ my $items='';
+ foreach my $item (keys(%clickers)) {
+ $items.=&escape($item).'='.&escape($clickers{$item}).'&';
+ }
+ $items=~s/\&$//;
+ my $request = "updateclickers:$udom:$action:$items";
+ if ($critical) {
+ return &critical($request,$uhome);
+ } else {
+ return &reply($request,$uhome);
+ }
+}
+
# ------------------------------dump from db file owned by domainconfig user
sub dump_dom {
my ($namespace, $udom, $regexp) = @_;
@@ -2132,7 +2377,7 @@ sub restore_dom {
}
}
my %returnhash=();
- unless (($answer eq '') || ($answer eq 'con_lost') || ($answer eq 'refused') ||
+ unless (($answer eq '') || ($answer eq 'con_lost') || ($answer eq 'refused') ||
($answer eq 'unknown_cmd') || ($answer eq 'rejected')) {
foreach my $line (split(/\&/,$answer)) {
my ($name,$value)=split(/\=/,$line);
@@ -2157,7 +2402,7 @@ sub get_domainconfiguser {
sub retrieve_inst_usertypes {
my ($udom) = @_;
my (%returnhash,@order);
- my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
+ my %domdefs = &get_domain_defaults($udom);
if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
@@ -2208,10 +2453,9 @@ sub inst_directory_query {
unless ($homeserver eq $perlvar{'lonHostID'}) {
if ($srch->{'srchby'} eq 'email') {
my $lcrev = &get_server_loncaparev($udom,$homeserver);
- my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
+ my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
if (($major eq '' && $minor eq '') || ($major < 2) ||
- (($major == 2) && ($minor < 11)) ||
- (($major == 2) && ($minor == 11) && ($subver < 3))) {
+ (($major == 2) && ($minor < 12))) {
return;
}
}
@@ -2260,10 +2504,9 @@ sub usersearch {
unless ($tryserver eq $perlvar{'lonHostID'}) {
if ($srch->{'srchby'} eq 'email') {
my $lcrev = &get_server_loncaparev($dom,$tryserver);
- my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
+ my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
next if (($major eq '' && $minor eq '') || ($major < 2) ||
- (($major == 2) && ($minor < 11)) ||
- (($major == 2) && ($minor == 11) && ($subver < 3)));
+ (($major == 2) && ($minor < 12)));
}
}
my $host=&hostname($tryserver);
@@ -2355,7 +2598,7 @@ sub get_multiple_instusers {
my ($udom,$users,$caller) = @_;
my ($outcome,$results);
if (ref($users) eq 'HASH') {
- my $count = keys(%{$users});
+ my $count = keys(%{$users});
my $requested = &freeze_escape($users);
my $homeserver = &domain($udom,'primary');
if ($homeserver ne '') {
@@ -2399,7 +2642,7 @@ sub get_multiple_instusers {
} else {
($outcome,my $userdata) = split(/=/,$response,2);
if ($outcome eq 'ok') {
- $results = &thaw_unescape($userdata);
+ $results = &thaw_unescape($userdata);
}
}
}
@@ -2426,14 +2669,14 @@ sub inst_rulecheck {
$response=&unescape(&reply('instidrulecheck:'.&escape($udom).
':'.&escape($id).':'.$rulestr,
$homeserver));
- } elsif ($item eq 'unamemap') {
- $response=&unescape(&reply('instunamemapcheck:'.
- &escape($udom).':'.&escape($uname).
- ':'.$rulestr,$homeserver));
} elsif ($item eq 'selfcreate') {
$response=&unescape(&reply('instselfcreatecheck:'.
&escape($udom).':'.&escape($uname).
':'.$rulestr,$homeserver));
+ } elsif ($item eq 'unamemap') {
+ $response=&unescape(&reply('instunamemapcheck:'.
+ &escape($udom).':'.&escape($uname).
+ ':'.$rulestr,$homeserver));
}
if ($response ne 'refused') {
my @pairs=split(/\&/,$response);
@@ -2465,7 +2708,7 @@ sub inst_userrules {
$homeserver);
} elsif ($check eq 'unamemap') {
$response=&reply('unamemaprules:'.&escape($udom),
- $homeserver);
+ $homeserver);
} else {
$response=&reply('instuserrules:'.&escape($udom),
$homeserver);
@@ -2507,15 +2750,16 @@ sub get_domain_defaults {
}
my %domdefaults;
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['defaults','quotas',
+ &get_dom('configuration',['defaults','quotas',
'requestcourses','inststatus',
'coursedefaults','usersessions',
'requestauthor','authordefaults',
'selfenrollment','coursecategories',
- 'autoenroll','helpsettings',
- 'wafproxy','ltisec','toolsec',
- 'domexttool','exttool'],$domain);
- my @coursetypes = ('official','unofficial','community','textbook');
+ 'ssl','autoenroll','trust',
+ 'helpsettings','wafproxy',
+ 'ltisec','toolsec','domexttool',
+ 'exttool','privacy'],$domain);
+ my @coursetypes = ('official','unofficial','community','textbook','placement');
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
@@ -2551,10 +2795,13 @@ sub get_domain_defaults {
}
}
if (ref($domconfig{'requestcourses'}) eq 'HASH') {
- foreach my $item ('official','unofficial','community','textbook') {
+ foreach my $item ('official','unofficial','community','textbook','placement') {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}
}
+ if (ref($domconfig{'requestauthor'}) eq 'HASH') {
+ $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
+ }
if (ref($domconfig{'authordefaults'}) eq 'HASH') {
foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors') {
if ($item eq 'editors') {
@@ -2566,15 +2813,13 @@ sub get_domain_defaults {
}
}
}
- if (ref($domconfig{'requestauthor'}) eq 'HASH') {
- $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
- }
if (ref($domconfig{'inststatus'}) eq 'HASH') {
foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {
$domdefaults{$item} = $domconfig{'inststatus'}{$item};
}
}
if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
+ $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
$domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
$domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
$domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
@@ -2595,8 +2840,8 @@ sub get_domain_defaults {
}
if ($domdefaults{'postsubmit'} eq 'on') {
if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
- $domdefaults{$type.'postsubtimeout'} =
- $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
+ $domdefaults{$type.'postsubtimeout'} =
+ $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
}
}
if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') {
@@ -2679,6 +2924,25 @@ sub get_domain_defaults {
$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
}
}
+ if (ref($domconfig{'ssl'}) eq 'HASH') {
+ if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') {
+ $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'};
+ }
+ if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') {
+ $domdefaults{'connect'} = $domconfig{'ssl'}{'connto'};
+ }
+ if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') {
+ $domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'};
+ }
+ }
+ if (ref($domconfig{'trust'}) eq 'HASH') {
+ my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg);
+ foreach my $prefix (@prefixes) {
+ if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') {
+ $domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix};
+ }
+ }
+ }
if (ref($domconfig{'autoenroll'}) eq 'HASH') {
$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
$domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};
@@ -2707,17 +2971,6 @@ sub get_domain_defaults {
$domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
}
}
- if (ref($domconfig{'ltisec'}{'suggested'}) eq 'HASH') {
- my %suggestions = %{$domconfig{'ltisec'}{'suggested'}};
- foreach my $item (keys(%{$domconfig{'ltisec'}{'suggested'}})) {
- unless (ref($domconfig{'ltisec'}{'suggested'}{$item}) eq 'HASH') {
- delete($suggestions{$item});
- }
- }
- if (keys(%suggestions)) {
- $domdefaults{'linkprotsuggested'} = \%suggestions;
- }
- }
}
if (ref($domconfig{'toolsec'}) eq 'HASH') {
if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
@@ -2730,6 +2983,21 @@ sub get_domain_defaults {
}
}
}
+ if (ref($domconfig{'privacy'}) eq 'HASH') {
+ if (ref($domconfig{'privacy'}{'approval'}) eq 'HASH') {
+ foreach my $domtype ('instdom','extdom') {
+ if (ref($domconfig{'privacy'}{'approval'}{$domtype}) eq 'HASH') {
+ foreach my $roletype ('domain','author','course','community') {
+ if ($domconfig{'privacy'}{'approval'}{$domtype}{$roletype} eq 'user') {
+ $domdefaults{'userapprovals'} = 1;
+ last;
+ }
+ }
+ }
+ last if ($domdefaults{'userapprovals'});
+ }
+ }
+ }
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;
}
@@ -2749,7 +3017,7 @@ sub get_dom_cats {
} else {
$cats = {};
}
- &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600);
+ &do_cache_new('cats',$dom,$cats,3600);
}
return $cats;
}
@@ -2794,29 +3062,6 @@ sub retrieve_instcodes {
return $totcodes;
}
-# --------------------------------------------- Get domain config for passwords
-
-sub get_passwdconf {
- my ($dom) = @_;
- my (%passwdconf,$gotconf,$lookup);
- my ($result,$cached)=&is_cached_new('passwdconf',$dom);
- if (defined($cached)) {
- if (ref($result) eq 'HASH') {
- %passwdconf = %{$result};
- $gotconf = 1;
- }
- }
- unless ($gotconf) {
- my %domconfig = &get_dom('configuration',['passwords'],$dom);
- if (ref($domconfig{'passwords'}) eq 'HASH') {
- %passwdconf = %{$domconfig{'passwords'}};
- }
- my $cachetime = 24*60*60;
- &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
- }
- return %passwdconf;
-}
-
sub course_portal_url {
my ($cnum,$cdom,$r) = @_;
my $chome = &homeserver($cnum,$cdom);
@@ -2828,7 +3073,7 @@ sub course_portal_url {
if ($domdefaults{'portal_def'}) {
$firsturl = $domdefaults{'portal_def'};
} else {
- my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
+ my $alias = &use_proxy_alias($r,$chome);
$hostname = $alias if ($alias ne '');
$firsturl = $protocol.'://'.$hostname;
}
@@ -2855,6 +3100,29 @@ sub url_prefix {
return $prefix;
}
+# --------------------------------------------- Get domain config for passwords
+
+sub get_passwdconf {
+ my ($dom) = @_;
+ my (%passwdconf,$gotconf,$lookup);
+ my ($result,$cached)=&is_cached_new('passwdconf',$dom);
+ if (defined($cached)) {
+ if (ref($result) eq 'HASH') {
+ %passwdconf = %{$result};
+ $gotconf = 1;
+ }
+ }
+ unless ($gotconf) {
+ my %domconfig = &get_dom('configuration',['passwords'],$dom);
+ if (ref($domconfig{'passwords'}) eq 'HASH') {
+ %passwdconf = %{$domconfig{'passwords'}};
+ }
+ my $cachetime = 24*60*60;
+ &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
+ }
+ return %passwdconf;
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -3003,7 +3271,7 @@ sub courseid_to_courseurl {
return "/$cdom/$cnum";
}
- my %courseinfo=&Apache::lonnet::coursedescription($courseid);
+ my %courseinfo=&coursedescription($courseid);
if (exists($courseinfo{'num'})) {
return "/$courseinfo{'domain'}/$courseinfo{'num'}";
}
@@ -3100,9 +3368,7 @@ sub devalidate_cache_new {
sub is_cached_new {
my ($name,$id,$debug) = @_;
- my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for
- # keys in %remembered hash, which persists for
- # duration of request (no restriction on key length).
+ my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) whenever possible
if (exists($remembered{$remembered_id})) {
if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
$accessed{$remembered_id}=[&gettimeofday()];
@@ -3203,14 +3469,14 @@ sub userenvironment {
# ---------------------------------------------------------- Get a studentphoto
sub studentphoto {
my ($udom,$unam,$ext) = @_;
- my $home=&Apache::lonnet::homeserver($unam,$udom);
+ my $home=&homeserver($unam,$udom);
if (defined($env{'request.course.id'})) {
if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
return(&retrievestudentphoto($udom,$unam,$ext));
} else {
my ($result,$perm_reqd)=
- &Apache::lonnet::auto_photo_permission($unam,$udom);
+ &auto_photo_permission($unam,$udom);
if ($result eq 'ok') {
if (!($perm_reqd eq 'yes')) {
return(&retrievestudentphoto($udom,$unam,$ext));
@@ -3220,7 +3486,7 @@ sub studentphoto {
}
} else {
my ($result,$perm_reqd) =
- &Apache::lonnet::auto_photo_permission($unam,$udom);
+ &auto_photo_permission($unam,$udom);
if ($result eq 'ok') {
if (!($perm_reqd eq 'yes')) {
return(&retrievestudentphoto($udom,$unam,$ext));
@@ -3232,14 +3498,14 @@ sub studentphoto {
sub retrievestudentphoto {
my ($udom,$unam,$ext,$type) = @_;
- my $home=&Apache::lonnet::homeserver($unam,$udom);
- my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
+ my $home=&homeserver($unam,$udom);
+ my $ret=&reply("studentphoto:$udom:$unam:$ext:$type",$home);
if ($ret eq 'ok') {
my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
if ($type eq 'thumbnail') {
$url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
}
- my $tokenurl=&Apache::lonnet::tokenwrapper($url);
+ my $tokenurl=&tokenwrapper($url);
return $tokenurl;
} else {
if ($type eq 'thumbnail') {
@@ -3364,9 +3630,13 @@ sub repcopy {
mkdir($path,0777);
}
}
- my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"$remoteurl");
- my $response=$ua->request($request,$transname);
+ my $response;
+ if ($remoteurl =~ m{/raw/}) {
+ $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1);
+ } else {
+ $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1);
+ }
if ($response->is_error()) {
unlink($transname);
my $message=$response->status_line;
@@ -3376,7 +3646,12 @@ sub repcopy {
} else {
if ($remoteurl!~/\.meta$/) {
my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
- my $mresponse=$ua->request($mrequest,$filename.'.meta');
+ my $mresponse;
+ if ($remoteurl =~ m{/raw/}) {
+ $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1);
+ } else {
+ $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1);
+ }
if ($mresponse->is_error()) {
unlink($filename.'.meta');
&logthis(
@@ -3406,7 +3681,12 @@ sub unsubscribe {
} elsif (grep { $_ eq $home } ¤t_machine_ids()) {
$answer = 'home';
} else {
- $answer = reply("unsub:$fname",$home);
+ my $defdom = $perlvar{'lonDefDomain'};
+ if (&will_trust('content',$defdom,$udom)) {
+ $answer = reply("unsub:$fname",$home);
+ } else {
+ $answer = 'untrusted';
+ }
}
return $answer;
}
@@ -3449,7 +3729,7 @@ sub absolute_url {
if ($alias eq $host_name) {
my $lonhost = $perlvar{'lonHostID'};
my $hostname = &hostname($lonhost);
- my $lcproto;
+ my $lcproto;
if (($keep_proto) || ($hostname eq '')) {
$lcproto = $protocol;
} else {
@@ -3461,7 +3741,7 @@ sub absolute_url {
return $lcproto.$hostname;
}
}
- }
+ }
return $protocol.$host_name;
}
@@ -3485,41 +3765,30 @@ sub ssi {
&Apache::lonenc::check_encrypt(\$fn);
if (%form) {
$request=new HTTP::Request('POST',$host.$fn);
- $request->content(join('&',map {
+ $request->content(join('&',map {
my $name = escape($_);
- "$name=" . ( ref($form{$_}) eq 'ARRAY'
- ? join("&$name=", map {escape($_) } @{$form{$_}})
- : &escape($form{$_}) );
+ "$name=" . ( ref($form{$_}) eq 'ARRAY'
+ ? join("&$name=", map {escape($_) } @{$form{$_}})
+ : &escape($form{$_}) );
} keys(%form)));
} else {
$request=new HTTP::Request('GET',$host.$fn);
}
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
-
+ my $lonhost = $perlvar{'lonHostID'};
+ my $islocal;
if (($env{'request.course.id'}) &&
($form{'grade_courseid'} eq $env{'request.course.id'}) &&
($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
($form{'grade_symb'} ne '') &&
- (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.
- ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
- if (LWP::UserAgent->VERSION >= 5.834) {
- my $ua=new LWP::UserAgent;
- $ua->local_address('127.0.0.1');
- $response = $ua->request($request);
- } else {
- {
- require LWP::Protocol::http;
- local @LWP::Protocol::http::EXTRA_SOCK_OPTS = (LocalAddr => '127.0.0.1');
- my $ua=new LWP::UserAgent;
- $response = $ua->request($request);
- @LWP::Protocol::http::EXTRA_SOCK_OPTS = ();
- }
- }
- } else {
- my $ua=new LWP::UserAgent;
- $response = $ua->request($request);
+ (&allowed('mgr',$env{'request.course.id'}.
+ ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
+ $islocal = 1;
}
+ $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
+ '','','',$islocal);
+
if (wantarray) {
return ($response->content, $response);
} else {
@@ -3529,9 +3798,8 @@ sub ssi {
sub externalssi {
my ($url)=@_;
- my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',$url);
- my $response=$ua->request($request);
+ my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar);
if (wantarray) {
return ($response->content, $response);
} else {
@@ -3539,8 +3807,9 @@ sub externalssi {
}
}
-# If the local copy of a replicated resource is outdated, trigger a
-# connection from the homeserver to flush the delayed queue. If no update
+
+# If the local copy of a replicated resource is outdated, trigger a
+# connection from the homeserver to flush the delayed queue. If no update
# happens, remove local copies of outdated resource (and corresponding
# metadata file).
@@ -3560,11 +3829,9 @@ sub remove_stale_resfile {
if ($hostname) {
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
- my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
- my $ua=new LWP::UserAgent;
- $ua->timeout(5);
- my $request=new HTTP::Request('HEAD',$uri);
- my $response=$ua->request($request);
+ my $uri = &declutter($url);
+ my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
+ my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
if ($response->is_success()) {
my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
my $locmodtime = (stat($fname))[9];
@@ -3627,7 +3894,7 @@ sub allowuploaded {
#
# Determine if the current user should be able to edit a particular resource,
# when viewing in course context.
-# (a) When viewing resource used to determine if "Edit" item is included in
+# (a) When viewing resource used to determine if "Edit" item is included in
# Functions.
# (b) When displaying folder contents in course editor, used to determine if
# "Edit" link will be displayed alongside resource.
@@ -3635,12 +3902,12 @@ sub allowuploaded {
# input: six args -- filename (decluttered), course number, course domain,
# url, symb (if registered) and group (if this is a group
# item -- e.g., bulletin board, group page etc.).
-# output: array of five scalars --
+# output: array of five scalars --
# $cfile -- url for file editing if editable on current server
# $home -- homeserver of resource (i.e., for author if published,
# or course if uploaded.).
# $switchserver -- 1 if server switch will be needed.
-# $forceedit -- 1 if icon/link should be to go to edit mode
+# $forceedit -- 1 if icon/link should be to go to edit mode
# $forceview -- 1 if icon/link should be to go to view mode
#
@@ -3666,8 +3933,31 @@ sub can_edit_resource {
}
}
+#
+# For /adm/viewcoauthors can only edit if author or co-author who is manager.
+#
+
+ if (($resurl eq '/adm/viewcoauthors') && ($cnum ne '') && ($cdom ne '')) {
+ if (((&allowed('cca',"$cdom/$cnum")) ||
+ (&allowed('caa',"$cdom/$cnum"))) ||
+ ((&allowed('vca',"$cdom/$cnum") ||
+ &allowed('vaa',"$cdom/$cnum")) &&
+ ($env{"environment.internal.manager./$cdom/$cnum"}))) {
+ $home = $env{'user.home'};
+ $cfile = $resurl;
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ } else {
+ $forceedit = 1;
+ }
+ return ($cfile,$home,$switchserver,$forceedit,$forceview);
+ } else {
+ return;
+ }
+ }
+
if ($env{'request.course.id'}) {
- my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});
+ my $crsedit = &allowed('mdc',$env{'request.course.id'});
if ($group ne '') {
# if this is a group homepage or group bulletin board, check group privs
my $allowed = 0;
@@ -3696,14 +3986,19 @@ sub can_edit_resource {
}
} else {
if ($resurl =~ m{^/?adm/viewclasslist$}) {
- unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {
+ unless (&allowed('opa',$env{'request.course.id'})) {
return;
}
} elsif (!$crsedit) {
+ if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) {
#
# No edit allowed where CC has switched to student role.
#
- return;
+ return;
+ } elsif (($resurl !~ m{^/res/$match_domain/$match_username/}) ||
+ ($resurl =~ m{^/res/lib/templates/})) {
+ return;
+ }
}
}
}
@@ -3780,7 +4075,7 @@ sub can_edit_resource {
}
} elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {
my $template = '/res/lib/templates/simpleproblem.problem';
- if (&is_on_map($template)) {
+ if (&is_on_map($template)) {
$incourse = 1;
$forceview = 1;
$cfile = $template;
@@ -3840,7 +4135,7 @@ sub can_edit_resource {
$cfile=$file;
}
}
- if (($cfile ne '') && (!$incourse || $uploaded) &&
+ if (($cfile ne '') && (!$incourse || $uploaded) &&
(($home ne '') && ($home ne 'no_host'))) {
my @ids=¤t_machine_ids();
unless (grep(/^\Q$home\E$/,@ids)) {
@@ -3867,9 +4162,9 @@ sub in_course {
if ($hideprivileged) {
my $skipuser;
my %coursehash = &coursedescription($cdom.'_'.$cnum);
- my @possdoms = ($cdom);
- if ($coursehash{'checkforpriv'}) {
- push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
+ my @possdoms = ($cdom);
+ if ($coursehash{'checkforpriv'}) {
+ push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
}
if (&privileged($uname,$udom,\@possdoms)) {
$skipuser = 1;
@@ -4063,7 +4358,7 @@ sub clean_filename {
# Replace all .\d. sequences with _\d. so they no longer look like version
# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;
-# Replace three or more adjacent underscores with one for consistency
+# Replace three or more adjacent underscores with one for consistency
# with loncfile::filename_check() so complete url can be extracted by
# lonnet::decode_symb()
$fname=~s/_{3,}/_/g;
@@ -4112,7 +4407,7 @@ sub resizeImage {
# input: $formname - the contents of the file are in $env{"form.$formname"}
# the desired filename is in $env{"form.$formname.filename"}
# $context - possible values: coursedoc, existingfile, overwrite,
-# canceloverwrite, scantron, toollogo or ''.
+# canceloverwrite, scantron, toollogo or ''.
# if 'coursedoc': upload to the current course
# if 'existingfile': write file to tmp/overwrites directory
# if 'canceloverwrite': delete file written to tmp/overwrites directory
@@ -4120,7 +4415,7 @@ sub resizeImage {
# $subdir - directory in userfile to store the file into
# $parser - instruction to parse file for objects ($parser = parse) or
# if context is 'scantron', $parser is hashref of csv column mapping
-# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,
+# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,
# Section => 4, CODE => 5, FirstQuestion => 9 }).
# $allfiles - reference to hash for embedded objects
# $codebase - reference to hash for codebase of java objects
@@ -4170,7 +4465,7 @@ sub userfileupload {
} else {
$docudom = $env{'user.domain'};
}
- if ($destuname =~ /^$match_username$/) {
+ if ($destuname =~ /^$match_username$/) {
$docuname = $destuname;
} else {
$docuname = $env{'user.name'};
@@ -4335,7 +4630,7 @@ sub finishuserfileupload {
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
my $input = $filepath.'/'.$file;
my $output = $filepath.'/'.'tn-'.$file;
- my $makethumb;
+ my $makethumb;
my $thumbsize = $thumbwidth.'x'.$thumbheight;
if ($context eq 'toollogo') {
my ($fullwidth,$fullheight) = &check_dimensions($input);
@@ -4351,7 +4646,7 @@ sub finishuserfileupload {
my @args = ('convert','-sample',$thumbsize,$input,$output);
system({$args[0]} @args);
if (-e $filepath.'/'.'tn-'.$file) {
- $fetchthumb = 1;
+ $fetchthumb = 1;
}
}
}
@@ -4409,7 +4704,7 @@ sub extract_embedded_items {
}
if (lc($tagname) eq 'a') {
unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
- &add_filetype($allfiles,$attr->{'href'},'href');
+ &add_filetype($allfiles,$attr->{'href'},'href');
}
}
if (lc($tagname) eq 'script') {
@@ -4614,7 +4909,7 @@ sub bubblesheet_converter {
($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
(-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
my (%csvcols,%csvoptions);
- if (ref($config->{'fields'}) eq 'HASH') {
+ if (ref($config->{'fields'}) eq 'HASH') {
%csvcols = %{$config->{'fields'}};
}
if (ref($config->{'options'}) eq 'HASH') {
@@ -4978,10 +5273,10 @@ sub flushcourselogs {
# That said there is a lot of noise in the data being stored.
# So counts for prtspool/ and adm/ etc. are recorded.
#
-# A review of which items ending '___count' are written to %accesshash should likely be
+# A review of which items ending '___count' are written to %accesshash should likely be
# made before deciding whether to set these to 'course.' instead of 'request.'
#
-# Under the current scheme each user receives a nohist_accesscount.db file listing
+# Under the current scheme each user receives a nohist_accesscount.db file listing
# accesses for things which are not published resources, regardless of course, and
# there is not a nohist_accesscount.db file in a course, which might log accesses from
# anyone in the course for things which are not published resources.
@@ -5015,7 +5310,7 @@ sub flushcourselogs {
foreach my $entry (keys(%userrolehash)) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=
split(/\:/,$entry);
- if (&Apache::lonnet::put('nohist_userroles',
+ if (&put('nohist_userroles',
{ $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
$rudom,$runame) eq 'ok') {
delete $userrolehash{$entry};
@@ -5037,19 +5332,19 @@ sub flushcourselogs {
delete $domainrolehash{$entry};
}
foreach my $dom (keys(%domrolebuffer)) {
- my %servers;
- if (defined(&domain($dom,'primary'))) {
- my $primary=&domain($dom,'primary');
- my $hostname=&hostname($primary);
- $servers{$primary} = $hostname;
- } else {
- %servers = &get_servers($dom,'library');
- }
+ my %servers;
+ if (defined(&domain($dom,'primary'))) {
+ my $primary=&domain($dom,'primary');
+ my $hostname=&hostname($primary);
+ $servers{$primary} = $hostname;
+ } else {
+ %servers = &get_servers($dom,'library');
+ }
foreach my $tryserver (keys(%servers)) {
if (&reply('domroleput:'.$dom.':'.
- $domrolebuffer{$dom},$tryserver) eq 'ok') {
- last;
- } else {
+ $domrolebuffer{$dom},$tryserver) eq 'ok') {
+ last;
+ } else {
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
}
}
@@ -5182,7 +5477,8 @@ sub userrolelog {
}
sub courserolelog {
- my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
+ my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,
+ $context,$othdomby,$requester)=@_;
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
my $cdom = $1;
my $cnum = $2;
@@ -5195,6 +5491,16 @@ sub courserolelog {
selfenroll => $selfenroll,
context => $context,
);
+ if ($othdomby) {
+ if ($othdomby eq 'othdombydc') {
+ $storehash{'approval'} = 'domain';
+ } elsif ($othdomby eq 'othdombyuser') {
+ $storehash{'approval'} = 'user';
+ }
+ if ($requester ne '') {
+ $storehash{'requester'} = $requester;
+ }
+ }
if ($trole eq 'gr') {
$namespace = 'groupslog';
$storehash{'group'} = $sec;
@@ -5220,7 +5526,7 @@ sub courserolelog {
my $putresult = &put('environment',{ 'internal.userdomains' => $newuserdomstr },
$cdom,$cnum);
if ($putresult eq 'ok') {
- unless (($selfenroll) || ($context eq 'selfenroll')) {
+ unless (($selfenroll) || ($context eq 'selfenroll')) {
if (($context eq 'createcourse') || ($context eq 'requestcourses') ||
($context eq 'automated') || ($context eq 'domain')) {
$env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'} = $newuserdomstr;
@@ -5241,10 +5547,11 @@ sub courserolelog {
}
sub domainrolelog {
- my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
+ my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
+ $context,$othdomby,$requester)=@_;
if ($area =~ m{^/($match_domain)/$}) {
my $cdom = $1;
- my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);
+ my $domconfiguser = &get_domainconfiguser($cdom);
my $namespace = 'rolelog';
my %storehash = (
role => $trole,
@@ -5252,6 +5559,16 @@ sub domainrolelog {
end => $tend,
context => $context,
);
+ if ($othdomby) {
+ if ($othdomby eq 'othdombydc') {
+ $storehash{'approval'} = 'domain';
+ } elsif ($othdomby eq 'othdombyuser') {
+ $storehash{'approval'} = 'user';
+ }
+ if ($requester ne '') {
+ $storehash{'requester'} = $requester;
+ }
+ }
&write_log('domain',$namespace,\%storehash,$delflag,$username,
$domain,$domconfiguser,$cdom);
}
@@ -5260,7 +5577,8 @@ sub domainrolelog {
}
sub coauthorrolelog {
- my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
+ my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
+ $context,$othdomby,$requester)=@_;
if ($area =~ m{^/($match_domain)/($match_username)$}) {
my $audom = $1;
my $auname = $2;
@@ -5271,6 +5589,16 @@ sub coauthorrolelog {
end => $tend,
context => $context,
);
+ if ($othdomby) {
+ if ($othdomby eq 'othdombydc') {
+ $storehash{'approval'} = 'domain';
+ } elsif ($othdomby eq 'othdombyuser') {
+ $storehash{'approval'} = 'user';
+ }
+ if ($requester ne '') {
+ $storehash{'requester'} = $requester;
+ }
+ }
&write_log('author',$namespace,\%storehash,$delflag,$username,
$domain,$auname,$audom);
}
@@ -5411,7 +5739,7 @@ sub get_my_roles {
} else {
my $possdoms = [$domain];
if (ref($roledoms) eq 'ARRAY') {
- push(@{$possdoms},@{$roledoms});
+ push(@{$possdoms},@{$roledoms});
}
if (&privileged($username,$domain,$possdoms,\@privroles)) {
if (!$nothide{$username.':'.$domain}) {
@@ -5475,8 +5803,8 @@ sub get_my_adhocroles {
} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
$cdom = $1;
$cnum = $2;
- %info = &Apache::lonnet::get('environment',['internal.coursecode'],
- $cdom,$cnum);
+ %info = &get('environment',['internal.coursecode'],
+ $cdom,$cnum);
}
if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
my $user = $env{'user.name'}.':'.$env{'user.domain'};
@@ -5708,16 +6036,16 @@ sub courseiddump {
if (($domfilter eq '') ||
(&host_domain($tryserver) eq $domfilter)) {
my $rep;
- if (grep { $_ eq $tryserver } ¤t_machine_ids()) {
- $rep = &LONCAPA::Lond::dump_course_id_handler(
- join(":", (&host_domain($tryserver), $sincefilter,
- &escape($descfilter), &escape($instcodefilter),
+ if (grep { $_ eq $tryserver } current_machine_ids()) {
+ $rep = LONCAPA::Lond::dump_course_id_handler(
+ join(":", (&host_domain($tryserver), $sincefilter,
+ &escape($descfilter), &escape($instcodefilter),
&escape($ownerfilter), &escape($coursefilter),
- &escape($typefilter), &escape($regexp_ok),
- $as_hash, &escape($selfenrollonly),
- &escape($catfilter), $showhidden, $caller,
- &escape($cloner), &escape($cc_clone), $cloneonly,
- &escape($createdbefore), &escape($createdafter),
+ &escape($typefilter), &escape($regexp_ok),
+ $as_hash, &escape($selfenrollonly),
+ &escape($catfilter), $showhidden, $caller,
+ &escape($cloner), &escape($cc_clone), $cloneonly,
+ &escape($createdbefore), &escape($createdafter),
&escape($creationcontext),$domcloner,$hasuniquecode,
$reqcrsdom,&escape($reqinstcode))));
} else {
@@ -5733,7 +6061,7 @@ sub courseiddump {
&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.
':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);
}
-
+
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -5803,7 +6131,7 @@ sub extract_lastaccess {
sub dcmailput {
my ($domain,$msgid,$message,$server)=@_;
- my $status = &Apache::lonnet::critical(
+ my $status = &critical(
'dcmailput:'.$domain.':'.&escape($msgid).'='.
&escape($message),$server);
return $status;
@@ -5960,93 +6288,6 @@ sub set_first_access {
}
}
-sub checkout {
- my ($symb,$tuname,$tudom,$tcrsid)=@_;
- my $now=time;
- my $lonhost=$perlvar{'lonHostID'};
- my $ip = &get_requestor_ip();
- my $infostr=&escape(
- 'CHECKOUTTOKEN&'.
- $tuname.'&'.
- $tudom.'&'.
- $tcrsid.'&'.
- $symb.'&'.
- $now.'&'.$ip);
- my $token=&reply('tmpput:'.$infostr,$lonhost);
- if ($token=~/^error\:/) {
- &logthis("WARNING: ".
- "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- return '';
- }
-
- $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
- $token=~tr/a-z/A-Z/;
-
- my %infohash=('resource.0.outtoken' => $token,
- 'resource.0.checkouttime' => $now,
- 'resource.0.outremote' => $ip);
-
- unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
- return '';
- } else {
- &logthis("WARNING: ".
- "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkout '.$infostr.' - '.
- $token)) ne 'ok') {
- return '';
- } else {
- &logthis("WARNING: ".
- "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- }
- return $token;
-}
-
-# ------------------------------------------------------------ Check in an item
-
-sub checkin {
- my $token=shift;
- my $now=time;
- my ($ta,$tb,$lonhost)=split(/\*/,$token);
- $lonhost=~tr/A-Z/a-z/;
- my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
- $dtoken=~s/\W/\_/g;
- my $ip = &get_requestor_ip();
- my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
- split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
-
- unless (($tuname) && ($tudom)) {
- &logthis('Check in '.$token.' ('.$dtoken.') failed');
- return '';
- }
-
- unless (&allowed('mgr',$tcrsid)) {
- &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
- $env{'user.name'}.' - '.$env{'user.domain'});
- return '';
- }
-
- my %infohash=('resource.0.intoken' => $token,
- 'resource.0.checkintime' => $now,
- 'resource.0.inremote' => $ip);
-
- unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
- return '';
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkin - '.$token)) ne 'ok') {
- return '';
- }
-
- return ($symb,$tuname,$tudom,$tcrsid);
-}
-
# --------------------------------------------- Set Expire Date for Spreadsheet
sub expirespread {
@@ -6640,7 +6881,7 @@ sub privileged {
my $now = time;
my $roles;
if (ref($possroles) eq 'ARRAY') {
- $roles = $possroles;
+ $roles = $possroles;
} else {
$roles = ['dc','su'];
}
@@ -6667,7 +6908,7 @@ sub privileged {
for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {
my ($trole, $tend, $tstart) = split(/_/, $role);
if (grep(/^\Q$trole\E$/,@{$roles})) {
- return 1 unless ($tend && $tend < $now)
+ return 1 unless ($tend && $tend < $now)
or ($tstart && $tstart > $now);
}
}
@@ -6705,7 +6946,7 @@ sub privileged_by_domain {
my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
next if ($end && $end < $now);
- $privileged{$dom}{$trole}{$uname.':'.$udom} =
+ $privileged{$dom}{$trole}{$uname.':'.$udom} =
$dompersonnel{$server}{$item};
}
}
@@ -6738,7 +6979,7 @@ sub rolesinit {
my %firstaccess = &dump('firstaccesstimes', $domain, $username);
my %timerinterval = &dump('timerinterval', $domain, $username);
my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
- %timerintchk, %timerintenv,%coauthorenv);
+ %timerintchk, %timerintenv, %coauthorenv);
foreach my $key (keys(%firstaccess)) {
my ($cid, $rest) = split(/\0/, $key);
@@ -6807,7 +7048,7 @@ sub rolesinit {
if (($trole eq 'ca') || ($trole eq 'aa')) {
(undef,my ($audom,$auname)) = split(/\//,$area);
unless ($gotcoauconfig{$area}) {
- my @ca_settings = ('authoreditors');
+ my @ca_settings = ('authoreditors','coauthorlist','coauthoroptin');
my %info = &userenvironment($audom,$auname,@ca_settings);
$gotcoauconfig{$area} = 1;
foreach my $item (@ca_settings) {
@@ -7156,7 +7397,7 @@ sub check_adhoc_privs {
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
if ($sec) {
$cckey .= '/'.$sec;
- }
+ }
my $setprivs;
if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
@@ -7202,7 +7443,7 @@ sub set_adhoc_privileges {
($caller eq 'tiny')) {
&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,
- 'request.course.sec' => $sec,
+ 'request.course.sec' => $sec,
}
);
my $tadv=0;
@@ -7262,14 +7503,15 @@ sub unserialize {
return {} if $rep =~ /^error/;
my %returnhash=();
- foreach my $item (split(/\&/,$rep)) {
- my ($key, $value) = split(/=/, $item, 2);
- $key = unescape($key) unless $escapedkeys;
- next if $key =~ /^error: 2 /;
- $returnhash{$key} = &thaw_unescape($value);
- }
+ foreach my $item (split(/\&/,$rep)) {
+ my ($key, $value) = split(/=/, $item, 2);
+ $key = unescape($key) unless $escapedkeys;
+ next if $key =~ /^error: 2 /;
+ $returnhash{$key} = &thaw_unescape($value);
+ }
+ #return %returnhash;
return \%returnhash;
-}
+}
# see Lond::dump_with_regexp
# if $escapedkeys hash keys won't get unescaped.
@@ -7284,11 +7526,11 @@ sub dump {
} else {
$regexp='.';
}
- if (grep { $_ eq $uhome } ¤t_machine_ids()) {
+ if (grep { $_ eq $uhome } current_machine_ids()) {
# user is hosted on this machine
- my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
+ my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
- return %{&unserialize($reply, $escapedkeys)};
+ return %{unserialize($reply, $escapedkeys)};
}
my $rep;
if ($encrypt) {
@@ -7301,7 +7543,8 @@ sub dump {
if (!($rep =~ /^error/ )) {
foreach my $item (@pairs) {
my ($key,$value)=split(/=/,$item,2);
- $key = &unescape($key) unless ($escapedkeys);
+ $key = unescape($key) unless $escapedkeys;
+ #$key = &unescape($key);
next if ($key =~ /^error: 2 /);
$returnhash{$key}=&thaw_unescape($value);
}
@@ -7345,7 +7588,7 @@ sub currentdump {
my $rep;
if (grep { $_ eq $uhome } current_machine_ids()) {
- $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,
+ $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,
$courseid)));
} else {
$rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
@@ -7355,7 +7598,7 @@ sub currentdump {
#
my %returnhash=();
#
- if ($rep eq "unknown_cmd") {
+ if ($rep eq 'unknown_cmd') {
# an old lond will not know currentdump
# Do a dump and make it look like a currentdump
my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
@@ -7499,7 +7742,7 @@ sub putstore {
'&host='.&escape($perlvar{'lonHostID'}).
'&version='.$esc_v.
'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
- &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
+ &courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
}
if ($reply eq 'unknown_cmd') {
# gfall back to way things use to be done
@@ -7611,13 +7854,13 @@ sub tmpdel {
return &reply("tmpdel:$token",$server);
}
-# ------------------------------------------------------------ get_timebased_id
+# ------------------------------------------------------------ get_timebased_id
sub get_timebased_id {
my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
$maxtries) = @_;
my ($newid,$error,$dellock);
- unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
+ unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
return ('','ok','invalid call to get suffix');
}
@@ -7631,7 +7874,7 @@ sub get_timebased_id {
if (!$maxtries) {
$maxtries = 10;
}
-
+
if (($cdom eq '') || ($cnum eq '')) {
if ($env{'request.course.id'}) {
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
@@ -7649,16 +7892,16 @@ sub get_timebased_id {
my $tries = 0;
# attempt to get lock on nohist_$namespace file
- my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
+ my $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
while (($gotlock ne 'ok') && $tries <$locktries) {
$tries ++;
sleep 1;
- $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
+ $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
}
# attempt to get unique identifier, based on current timestamp
if ($gotlock eq 'ok') {
- my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
+ my %inuse = &dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
my $id = time;
$newid = $id;
if ($idtype eq 'addcode') {
@@ -7679,7 +7922,7 @@ sub get_timebased_id {
my %new_item = (
$prefix."\0".$newid => $who,
);
- my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,
+ my $putresult = &put('nohist_'.$namespace,\%new_item,
$cdom,$cnum);
if ($putresult ne 'ok') {
undef($newid);
@@ -7721,11 +7964,11 @@ sub portfolio_access {
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
- if (($startblock && $endblock) || ($by_ip)) {
+ if (($startblock && $endblock) || ($by_ip)) {
return 'B';
}
} else {
- my ($startblock,$endblock,$triggerblock,$by_ip,$blockdo) =
+ my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port',$clientip);
if (($startblock && $endblock) || ($by_ip)) {
return 'B';
@@ -7786,7 +8029,7 @@ sub get_portfolio_access {
if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
$allowed = 1;
- last;
+ last;
}
}
}
@@ -7991,6 +8234,7 @@ sub usertools_access {
unofficial => 1,
community => 1,
textbook => 1,
+ placement => 1,
lti => 1,
);
} elsif ($context eq 'requestauthor') {
@@ -8006,6 +8250,7 @@ sub usertools_access {
aboutme => 1,
blog => 1,
portfolio => 1,
+ portaccess => 1,
timezone => 1,
);
}
@@ -8139,7 +8384,7 @@ sub is_course_owner {
if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
return 1;
} else {
- my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);
+ my %courseinfo = &coursedescription($cdom.'/'.$cnum);
if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
return 1;
}
@@ -8150,7 +8395,8 @@ sub is_course_owner {
}
sub is_advanced_user {
- my ($udom,$uname) = @_;
+ my ($udom,$uname,$nocache) = @_;
+ my ($is_adv,$is_author,$use_cache,$hashid);
if ($udom ne '' && $uname ne '') {
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
if (wantarray) {
@@ -8158,11 +8404,21 @@ sub is_advanced_user {
} else {
return $env{'user.adv'};
}
+ } elsif (!$nocache) {
+ $use_cache = 1;
+ $hashid = "$udom:$uname";
+ my ($info,$cached)=&is_cached_new('isadvau',$hashid);
+ if ($cached) {
+ ($is_adv,$is_author) = split(/:/,$info);
+ if (wantarray) {
+ return ($is_adv,$is_author);
+ }
+ return $is_adv;
+ }
}
}
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
my %allroles;
- my ($is_adv,$is_author);
foreach my $role (keys(%roleshash)) {
my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
my $area = '/'.$tdomain.'/'.$trest;
@@ -8193,6 +8449,10 @@ sub is_advanced_user {
}
}
}
+ if ($use_cache) {
+ my $cachetime = 600;
+ &do_cache_new('isadvau',$hashid,$is_adv.':'.$is_author,$cachetime);
+ }
if (wantarray) {
return ($is_adv,$is_author);
}
@@ -8210,6 +8470,7 @@ sub check_can_request {
my @options = ('approval','validate','autolimit');
my $optregex = join('|',@options);
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
+ my %willtrust;
foreach my $type (@{$types}) {
if (&usertools_access($uname,$udom,$type,undef,
'requestcourses')) {
@@ -8229,12 +8490,17 @@ sub check_can_request {
if (ref($request_domains) eq 'HASH') {
my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
if ($otherdom ne '') {
- if (ref($request_domains->{$type}) eq 'ARRAY') {
- unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
+ unless (exists($willtrust{$otherdom})) {
+ $willtrust{$otherdom} = &will_trust('reqcrs',$env{'user.domain'},$otherdom);
+ }
+ if ($willtrust{$otherdom}) {
+ if (ref($request_domains->{$type}) eq 'ARRAY') {
+ unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
+ push(@{$request_domains->{$type}},$otherdom);
+ }
+ } else {
push(@{$request_domains->{$type}},$otherdom);
}
- } else {
- push(@{$request_domains->{$type}},$otherdom);
}
}
}
@@ -8583,7 +8849,7 @@ sub allowed {
&& &is_portfolio_url($uri)) {
$thisallowed = &portfolio_access($uri,$clientip);
}
-
+
# Full access at system, domain or course-wide level? Exit.
if ($thisallowed=~/F/) {
return 'F';
@@ -8591,7 +8857,7 @@ sub allowed {
# If this is generating or modifying users, exit with special codes
- if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
+ if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:vca:vaa:'=~/\:\Q$priv\E\:/) {
if (($priv eq 'cca') || ($priv eq 'caa')) {
my ($audom,$auname)=split('/',$uri);
# no author name given, so this just checks on the general right to make a co-author in this domain
@@ -8600,6 +8866,13 @@ sub allowed {
if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
($audom ne $env{'request.role.domain'}))) { return ''; }
+ } elsif (($priv eq 'vca') || ($priv eq 'vaa')) {
+ my ($audom,$auname)=split('/',$uri);
+ unless ($auname) { return $thisallowed; }
+ unless (($env{'request.role'} eq "dc./$audom") ||
+ ($env{'request.role'} eq "ca./$uri")) {
+ return '';
+ }
}
return $thisallowed;
}
@@ -8842,7 +9115,7 @@ sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {
- if (($priv ne 'pch') && ($priv ne 'plc')) {
+ if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$env{'request.course.id'});
@@ -8852,7 +9125,7 @@ sub allowed {
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {
- if (($priv ne 'pch') && ($priv ne 'plc')) {
+ if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
$env{'request.course.id'});
@@ -8937,6 +9210,18 @@ sub constructaccess {
if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
return ($ownername,$ownerdomain,$ownerhome);
}
+ } elsif (&is_course($ownerdomain,$ownername)) {
+# Course Authoring Space?
+ if ($env{'request.course.id'}) {
+ if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
+ ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
+ if (&allowed('mdc',$env{'request.course.id'})) {
+ $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
+ return ($ownername,$ownerdomain,$ownerhome);
+ }
+ }
+ }
+ return '';
} else {
# Co-author for this?
if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||
@@ -8988,14 +9273,14 @@ sub constructaccess {
my $cacheduser='';
# Course for which data are being temporarily cached.
my $cachedcid='';
-# Cached blockers for this user (a hash of blocking items).
+# Cached blockers for this user (a hash of blocking items).
my %cachedblockers=();
# When the data were last cached.
my $cachedlast='';
sub load_all_blockers {
my ($uname,$udom)=@_;
- if (($uname ne '') && ($udom ne '')) {
+ if (($uname ne '') && ($udom ne '')) {
if (($cacheduser eq $uname.':'.$udom) &&
($cachedcid eq $env{'request.course.id'}) &&
(abs($cachedlast-time)<5)) {
@@ -9022,7 +9307,7 @@ sub get_comm_blocks {
if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
%commblocks = %{$blocksref};
} else {
- %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
+ %commblocks = &dump('comm_block',$cdom,$cnum);
my $cachetime = 600;
&do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
}
@@ -9044,7 +9329,7 @@ sub get_commblock_resources {
} else {
%commblocks = &get_comm_blocks();
}
- return %blockers unless (keys(%commblocks) > 0);
+ return %blockers unless (keys(%commblocks) > 0);
my $navmap = Apache::lonnavmaps::navmap->new();
return %blockers unless (ref($navmap));
my $now = time;
@@ -9056,7 +9341,7 @@ sub get_commblock_resources {
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
- $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
+ $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
}
}
if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
@@ -9089,7 +9374,7 @@ sub get_commblock_resources {
}
}
if ($interval[0] =~ /^(\d+)/) {
- my $timelimit = $1;
+ my $timelimit = $1;
my $first_access;
if ($type eq 'resource') {
$first_access=&get_first_access($interval[1],$item);
@@ -9182,7 +9467,7 @@ sub has_comm_blocking {
}
if ($symb) {
@symbs = ($symb);
- } elsif (keys(%possibles)) {
+ } elsif (keys(%possibles)) {
@symbs = keys(%possibles);
}
my $noblock;
@@ -9217,7 +9502,7 @@ sub has_comm_blocking {
}
}
}
- unless ($noblock) {
+ unless ($noblock) {
return @blockers;
}
return;
@@ -9305,7 +9590,7 @@ sub deeplink_check {
return 1;
}
-# -------------------------------- Deversion and split uri into path an filename
+# -------------------------------- Deversion and split uri into path an filename
#
# Removes the version from a URI and
@@ -9431,9 +9716,9 @@ sub metadata_query {
my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );
for my $server (@server_list) {
- my $domains = '';
+ my $domains = '';
if (ref($domains_hash) eq 'HASH') {
- $domains = $domains_hash->{$server};
+ $domains = $domains_hash->{$server};
}
unless ($custom or $customshow) {
my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
@@ -10064,7 +10349,8 @@ sub auto_crsreq_update {
':'.&escape($action).':'.&escape($ownername).':'.
&escape($ownerdomain).':'.&escape($fullname).':'.
&escape($title).':'.&escape($code).':'.
- &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);
+ &escape($accessstart).':'.&escape($accessend).':'.$info,
+ $homeserver);
unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
my @items = split(/&/,$response);
foreach my $item (@items) {
@@ -10221,11 +10507,13 @@ sub toggle_coursegroup_status {
}
sub modify_group_roles {
- my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
+ my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context,
+ $othdomby,$requester) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
my $role = 'gr/'.&escape($userprivs);
my ($uname,$udom) = split(/:/,$user);
- my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
+ my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context,
+ $othdomby,$requester);
if ($result eq 'ok') {
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
}
@@ -10324,6 +10612,7 @@ sub plaintext {
my %rolenames = (
Course => 'std',
Community => 'alt1',
+ Placement => 'std',
);
if ($cid ne '') {
if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
@@ -10352,43 +10641,66 @@ sub plaintext {
sub assignrole {
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
- $context)=@_;
- my $mrole;
+ $context,$othdomby,$requester,$reqsec,$reqrole)=@_;
+ my ($mrole,$rolelogcontext);
if ($role =~ /^cr\//) {
my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
- unless (&allowed('ccr',$cwosec)) {
- my $refused = 1;
- if ($context eq 'requestcourses') {
- if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
- if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
- if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
- my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
- my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
- if ($crsenv{'internal.courseowner'} eq
- $env{'user.name'}.':'.$env{'user.domain'}) {
- $refused = '';
- }
- }
- }
- }
- }
- if ($refused) {
- &logthis('Refused custom assignrole: '.
- $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
- ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
- return 'refused';
- }
+ if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {
+ my $refused = 1;
+ if ($context eq 'requestcourses') {
+ if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
+ if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
+ if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
+ my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
+ my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+ if ($crsenv{'internal.courseowner'} eq
+ $env{'user.name'}.':'.$env{'user.domain'}) {
+ $refused = '';
+ }
+ }
+ }
+ }
+ } elsif (($context eq 'course') && ($othdomby eq 'othdombyuser')) {
+ my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
+ my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
+ my $key = "$uname:$udom:$role:$sec";
+ my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
+ if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
+ if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
+ $refused = '';
+ }
+ }
+ }
+ if ($refused) {
+ &logthis('Refused custom assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
+ ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
}
$mrole='cr';
} elsif ($role =~ /^gr\//) {
my $cwogrp=$url;
$cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
- unless (&allowed('mdg',$cwogrp)) {
- &logthis('Refused group assignrole: '.
- $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
- $env{'user.name'}.' at '.$env{'user.domain'});
- return 'refused';
+ if (!&allowed('mdg',$cwogrp)) {
+ my $refused = 1;
+ if (($refused) && ($othdomby eq 'othdombyuser') && ($requester ne '') && ($reqrole ne '')) {
+ my ($cdom,$cnum) = ($cwogrp =~ m{^/?($match_domain)/($match_courseid)$});
+ my $key = "$uname:$udom:$reqrole:$reqsec";
+ my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
+ if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
+ if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
+ $refused = '';
+ }
+ }
+ }
+ if ($refused) {
+ &logthis('Refused group assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+ $env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
}
$mrole='gr';
} else {
@@ -10405,7 +10717,8 @@ sub assignrole {
}
if ($refused) {
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
- if (!$selfenroll && $context eq 'course') {
+ if (!$selfenroll && ($othdomby ne 'othdombyuser') &&
+ (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
my %crsenv;
if ($role eq 'cc' || $role eq 'co') {
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
@@ -10431,6 +10744,49 @@ sub assignrole {
} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
$refused = '';
}
+ } elsif ($othdomby eq 'othdombyuser') {
+ my ($key,%queuedrolereq);
+ if ($context eq 'course') {
+ my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
+ $key = "$uname:$udom:$role:$sec";
+ %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
+ if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
+ if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
+ if ((($role eq 'cc') && ($cnum !~ /^$match_community$/)) ||
+ (($role eq 'co') && ($cnum =~ /^$match_community$/))) {
+ my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+ if ($crsenv{'internal.courseowner'} eq $requester) {
+ $refused = '';
+ }
+ } elsif ($role =~ /^(?:in|ta|ep|st)$/) {
+ $refused = '';
+ }
+ }
+ }
+ } elsif (($context eq 'author') && ($role =~ /^ca|aa$/)) {
+ my $key = "$uname:$udom:$role";
+ my ($audom,$auname) = ($url =~ m{^/($match_domain)/($match_username)$});
+ if (($audom ne '') && ($auname ne '')) {
+ my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$audom,$auname);
+ if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
+ if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
+ $refused = '';
+ }
+ }
+ }
+ } elsif (($context eq 'domain') && ($role ne 'dc') && ($role ne 'su')) {
+ my $key = "$uname:$udom:$role";
+ my ($roledom) = ($url =~ m{^/($match_domain)/\Q$role\E$});
+ if ($roledom ne '') {
+ my $confname = $roledom.'-domainconfig';
+ my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$roledom,$confname);
+ if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
+ if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
+ $refused = '';
+ }
+ }
+ }
+ }
} elsif ($context eq 'requestcourses') {
my @possroles = ('st','ta','ep','in','cc','co');
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
@@ -10449,7 +10805,7 @@ sub assignrole {
}
}
} elsif ($context eq 'requestauthor') {
- if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
($url eq '/'.$udom.'/') && ($role eq 'au')) {
if ($env{'environment.requestauthor'} eq 'automatic') {
$refused = '';
@@ -10457,13 +10813,13 @@ sub assignrole {
my %domdefaults = &get_domain_defaults($udom);
if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
my $checkbystatus;
- if ($env{'user.adv'}) {
+ if ($env{'user.adv'}) {
my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
if ($disposition eq 'automatic') {
$refused = '';
} elsif ($disposition eq '') {
$checkbystatus = 1;
- }
+ }
} else {
$checkbystatus = 1;
}
@@ -10483,6 +10839,15 @@ sub assignrole {
}
}
}
+ } elsif (($context eq 'author') && (($role eq 'ca' || $role eq 'aa'))) {
+ if ($url =~ m{^/($match_domain)/($match_username)$}) {
+ my ($audom,$auname) = ($1,$2);
+ if ((&Apache::lonnet::allowed('v'.$role,"$audom/$auname")) &&
+ ($env{"environment.internal.manager.$url"})) {
+ $refused = '';
+ $rolelogcontext = 'coauthor';
+ }
+ }
}
if ($refused) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
@@ -10543,15 +10908,18 @@ sub assignrole {
$origstart,$selfenroll,$context);
}
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
- $selfenroll,$context);
+ $selfenroll,$context,$othdomby,$requester);
} elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') ||
($role eq 'da')) {
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
- $context);
+ $context,$othdomby,$requester);
} elsif (($role eq 'ca') || ($role eq 'aa')) {
+ if ($rolelogcontext eq '') {
+ $rolelogcontext = $context;
+ }
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
- $context);
+ $rolelogcontext,$othdomby,$requester);
}
if ($role eq 'cc') {
&autoupdate_coowners($url,$end,$start,$uname,$udom);
@@ -10646,10 +11014,10 @@ sub store_coowners {
}
if (($putresult eq 'ok') || ($delresult eq 'ok')) {
my %crsinfo =
- &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
+ &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
if (ref($crsinfo{$cid}) eq 'HASH') {
$crsinfo{$cid}{'co-owners'} = \@newcoowners;
- my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');
+ my $cidput = &courseidput($cdom,\%crsinfo,$chome,'notime');
}
}
}
@@ -10771,7 +11139,7 @@ sub modifyuser {
'current user id "'.$uidhash{$uname}.'".';
}
} else {
- &idput($udom,($uname => $uid));
+ &idput($udom,{$uname => $uid},$uhome,'ids');
}
}
# -------------------------------------------------------------- Add names, etc
@@ -10867,7 +11235,7 @@ sub modifyuser {
return 'error: '.$reply;
}
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
- &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);
+ &devalidate_cache_new('emailscache',$uname.':'.$udom);
}
my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);
@@ -10896,14 +11264,14 @@ sub modifystudent {
# student's environment
$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
- $gene,$usec,$end,$start,$type,$locktype,
+ $gene,$usec,$end,$start,$type,$locktype,
$cid,$selfenroll,$context,$credits,$instsec);
return $reply;
}
sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
- $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;
+ $locktype,$cid,$selfenroll,$context,$credits,$instsec,$othdomby,$requester) = @_;
my ($cdom,$cnum,$chome);
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
@@ -10947,7 +11315,7 @@ sub modify_student_enrollment {
}
my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
my $user = "$uname:$udom";
- my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
+ my %old_entry = &get('classlist',[$user],$cdom,$cnum);
my $reply=cput('classlist',
{$user =>
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
@@ -10964,7 +11332,7 @@ sub modify_student_enrollment {
$uurl.='/'.$usec;
}
my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
- $selfenroll,$context);
+ $selfenroll,$context,$othdomby,$requester);
if ($result ne 'ok') {
if ($old_entry{$user} ne '') {
$reply = &cput('classlist',\%old_entry,$cdom,$cnum);
@@ -11081,7 +11449,7 @@ sub createcourse {
}
}
my %host_servers =
- &Apache::lonnet::get_servers($udom,'library');
+ &get_servers($udom,'library');
unless ($host_servers{$course_server}) {
return 'error: invalid home server for course: '.$course_server;
}
@@ -11178,6 +11546,7 @@ sub generate_coursenum {
sub is_course {
my ($cdom, $cnum) = scalar(@_) == 1 ?
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;
+
return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
my $uhome=&homeserver($cnum,$cdom);
my $iscourse;
@@ -11196,7 +11565,7 @@ sub is_course {
&do_cache_new('iscourse',$hashid,$iscourse,3600);
}
}
- return unless($iscourse);
+ return unless ($iscourse);
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
}
@@ -11239,9 +11608,11 @@ sub store_userdata {
# ---------------------------------------------------------- Assign Custom Role
sub assigncustomrole {
- my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
+ my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,
+ $selfenroll,$context,$othdomby,$requester)=@_;
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
- $end,$start,$deleteflag,$selfenroll,$context);
+ $end,$start,$deleteflag,$selfenroll,$context,$othdomby,
+ $requester);
}
# ----------------------------------------------------------------- Revoke Role
@@ -11395,6 +11766,90 @@ sub files_not_in_path {
return (@return_files);
}
+#------------------------------Submitted/Handedback Portfolio Files Versioning
+
+sub portfiles_versioning {
+ my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_;
+ my $portfolio_root = '/userfiles/portfolio';
+ return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY'));
+ foreach my $file (@{$portfiles}) {
+ &unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file);
+ my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/);
+ my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file);
+ my $getpropath = 1;
+ my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain,
+ $stu_name,$getpropath);
+ my $version = &get_next_version($answer_name,$answer_ext,$dir_list);
+ my $new_answer =
+ &version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version);
+ if ($new_answer ne 'problem getting file') {
+ push(@{$versioned_portfiles}, $directory.$new_answer);
+ &mark_as_readonly($domain,$stu_name,[$directory.$new_answer],
+ [$symb,$env{'request.course.id'},'graded']);
+ }
+ }
+}
+
+sub get_next_version {
+ my ($answer_name, $answer_ext, $dir_list) = @_;
+ my $version;
+ if (ref($dir_list) eq 'ARRAY') {
+ foreach my $row (@{$dir_list}) {
+ my ($file) = split(/\&/,$row,2);
+ my ($file_name,$file_version,$file_ext) =
+ &file_name_version_ext($file);
+ if (($file_name eq $answer_name) &&
+ ($file_ext eq $answer_ext)) {
+ # gets here if filename and extension match,
+ # regardless of version
+ if ($file_version ne '') {
+ # a versioned file is found so save it for later
+ if ($file_version > $version) {
+ $version = $file_version;
+ }
+ }
+ }
+ }
+ }
+ $version ++;
+ return($version);
+}
+
+sub version_selected_portfile {
+ my ($domain,$stu_name,$directory,$file_name,$version) = @_;
+ my ($answer_name,$answer_ver,$answer_ext) =
+ &file_name_version_ext($file_name);
+ my $new_answer;
+ $env{'form.copy'} =
+ &getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name");
+ if($env{'form.copy'} eq '-1') {
+ $new_answer = 'problem getting file';
+ } else {
+ $new_answer = $answer_name.'.'.$version.'.'.$answer_ext;
+ my $copy_result =
+ &finishuserfileupload($stu_name,$domain,'copy',
+ '/portfolio'.$directory.$new_answer);
+ }
+ undef($env{'form.copy'});
+ return ($new_answer);
+}
+
+sub file_name_version_ext {
+ my ($file)=@_;
+ my @file_parts = split(/\./, $file);
+ my ($name,$version,$ext);
+ if (@file_parts > 1) {
+ $ext=pop(@file_parts);
+ if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) {
+ $version=pop(@file_parts);
+ }
+ $name=join('.',@file_parts);
+ } else {
+ $name=join('.',@file_parts);
+ }
+ return($name,$version,$ext);
+}
+
#----------------------------------------------Get portfolio file permissions
sub get_portfile_permissions {
@@ -11539,49 +11994,132 @@ sub modify_access_controls {
}
sub make_public_indefinitely {
- my ($requrl) = @_;
+ my (@requrl) = @_;
+ return &automated_portfile_access('public',\@requrl);
+}
+
+sub automated_portfile_access {
+ my ($accesstype,$addsref,$delsref,$info) = @_;
+ unless (($accesstype eq 'public') || ($accesstype eq 'ip')) {
+ return 'invalid';
+ }
+ my %urls;
+ if (ref($addsref) eq 'ARRAY') {
+ foreach my $requrl (@{$addsref}) {
+ if (&is_portfolio_url($requrl)) {
+ unless (exists($urls{$requrl})) {
+ $urls{$requrl} = 'add';
+ }
+ }
+ }
+ }
+ if (ref($delsref) eq 'ARRAY') {
+ foreach my $requrl (@{$delsref}) {
+ if (&is_portfolio_url($requrl)) {
+ unless (exists($urls{$requrl})) {
+ $urls{$requrl} = 'delete';
+ }
+ }
+ }
+ }
+ unless (keys(%urls)) {
+ return 'invalid';
+ }
+ my $ip;
+ if ($accesstype eq 'ip') {
+ if (ref($info) eq 'HASH') {
+ if ($info->{'ip'} ne '') {
+ $ip = $info->{'ip'};
+ }
+ }
+ if ($ip eq '') {
+ return 'invalid';
+ }
+ }
+ my $errors;
my $now = time;
- my $action = 'activate';
- my $aclnum = 0;
- if (&is_portfolio_url($requrl)) {
+ my %current_perms;
+ foreach my $requrl (sort(keys(%urls))) {
+ my $action;
+ if ($urls{$requrl} eq 'add') {
+ $action = 'activate';
+ } else {
+ $action = 'none';
+ }
+ my $aclnum = 0;
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,
+ unless (exists($current_perms{$unum.':'.$udom})) {
+ $current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum);
+ }
+ my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom},
$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 {
+ if ($scope eq $accesstype) {
+ if (($start <= $now) && ($end == 0)) {
+ if ($accesstype eq 'ip') {
+ if (ref($access_controls{$file_name}{$key}) eq 'HASH') {
+ if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') {
+ if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) {
+ if ($urls{$requrl} eq 'add') {
+ $action = 'none';
+ last;
+ } else {
+ $action = 'delete';
+ $aclnum = $num;
+ last;
+ }
+ }
+ }
+ }
+ } elsif ($accesstype eq 'public') {
+ if ($urls{$requrl} eq 'add') {
+ $action = 'none';
+ last;
+ } else {
+ $action = 'delete';
+ $aclnum = $num;
+ last;
+ }
+ }
+ } elsif ($accesstype eq 'public') {
$action = 'update';
$aclnum = $num;
+ last;
}
- last;
}
}
if ($action eq 'none') {
- return 'ok';
+ next;
} else {
my %changes;
my $newend = 0;
my $newstart = $now;
- my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
+ my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart;
$changes{$action}{$newkey} = {
- type => 'public',
+ type => $accesstype,
time => {
start => $newstart,
end => $newend,
},
};
+ if ($accesstype eq 'ip') {
+ $changes{$action}{$newkey}{'ip'} = [$ip];
+ }
my ($outcome,$deloutcome,$new_values,$translation) =
&modify_access_controls($file_name,\%changes,$udom,$unum);
- return $outcome;
+ unless ($outcome eq 'ok') {
+ $errors .= $outcome.' ';
+ }
}
+ }
+ if ($errors) {
+ $errors =~ s/\s$//;
+ return $errors;
} else {
- return 'invalid';
+ return 'ok';
}
}
@@ -11786,11 +12324,12 @@ sub dirlist {
foreach my $user (sort(keys(%allusers))) {
push(@alluserslist,$user.'&user');
}
+
if (!%listerror) {
# no errors
return (\@alluserslist);
} elsif (scalar(keys(%servers)) == 1) {
- # one library server, one error
+ # one library server, one error
my ($key) = keys(%listerror);
return (\@alluserslist, $listerror{$key});
} elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {
@@ -11799,7 +12338,7 @@ sub dirlist {
return (\@alluserslist, 'con_lost');
} else {
# multiple library servers and no con_lost -> data should be
- # complete.
+ # complete.
return (\@alluserslist);
}
@@ -11875,6 +12414,173 @@ sub stat_file {
return ();
}
+# --------------------------------------------------------- recursedirs
+# Recursive function to traverse either a specific user's Authoring Space
+# or corresponding Published Resource Space, and populate the hash ref:
+# $dirhashref with URLs of all directories, and if $filehashref hash
+# ref arg is provided, the URLs of any files, excluding versioned, .meta,
+# or .rights files in resource space, and .meta, .save, .log, .bak and
+# .rights files in Authoring Space.
+#
+# Inputs:
+#
+# $is_home - true if current server is home server for user's space
+# $recurse - if true will also traverse subdirectories recursively
+# $include - reference to hash containing allowed file extensions. If provided,
+# files which do not have a matching extension will be ignored.
+# $exclude - reference to hash containing excluded file extensions. If provided,
+# files which have a matching extension will be ignored.
+# $nonemptydir - if true, will only populate $fileshashref hash entry for a particular
+# directory with first file found (with acceptable extension).
+# $addtopdir - if true, set $dirhashref->{'/'} = 1
+# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
+# $relpath - Current path (relative to top level).
+# $dirhashref - reference to hash to populate with URLs of directories (Required)
+# $filehashref - reference to hash to populate with URLs of files (Optional)
+#
+# Returns: nothing
+#
+# Side Effects: populates $dirhashref, and $filehashref (if provided).
+#
+# Currently used by interface/londocs.pm to create linked select boxes for
+# directory and filename to import a Course "Author" resource into a course, and
+# also to create linked select boxes for Authoring Space and Directory to choose
+# save location for creation of a new "standard" problem from the Course Editor.
+#
+
+sub recursedirs {
+ my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;
+ return unless (ref($dirhashref) eq 'HASH');
+ my $docroot = $perlvar{'lonDocRoot'};
+ my $currpath = $docroot.$toppath;
+ if ($relpath ne '') {
+ $currpath .= "/$relpath";
+ }
+ my ($savefile,$checkinc,$checkexc);
+ if (ref($filehashref)) {
+ $savefile = 1;
+ }
+ if (ref($include) eq 'HASH') {
+ $checkinc = 1;
+ }
+ if (ref($exclude) eq 'HASH') {
+ $checkexc = 1;
+ }
+ if ($is_home) {
+ if ((-e $currpath) && (opendir(my $dirh,$currpath))) {
+ my $filecount = 0;
+ foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
+ next if ($item eq '');
+ if (-d "$currpath/$item") {
+ my $newpath;
+ if ($relpath ne '') {
+ $newpath = "$relpath/$item";
+ } else {
+ $newpath = $item;
+ }
+ $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
+ if ($recurse) {
+ &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
+ }
+ } elsif (($savefile) || ($relpath eq '')) {
+ next if ($nonemptydir && $filecount);
+ if ($checkinc || $checkexc) {
+ my ($extension) = ($item =~ /\.(\w+)$/);
+ if ($checkinc) {
+ next unless ($extension && $include->{$extension});
+ }
+ if ($checkexc) {
+ next if ($extension && $exclude->{$extension});
+ }
+ }
+ if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
+ $dirhashref->{'/'} = 1;
+ }
+ if ($savefile) {
+ if ($relpath eq '') {
+ $filehashref->{'/'}{$item} = 1;
+ } else {
+ $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
+ }
+ }
+ $filecount ++;
+ }
+ }
+ closedir($dirh);
+ }
+ } else {
+ my ($dirlistref,$listerror) =
+ &dirlist($toppath.$relpath);
+ my @dir_lines;
+ my $dirptr=16384;
+ if (ref($dirlistref) eq 'ARRAY') {
+ my $filecount = 0;
+ foreach my $dir_line (sort
+ {
+ my ($afile)=split('&',$a,2);
+ my ($bfile)=split('&',$b,2);
+ return (lc($afile) cmp lc($bfile));
+ } (@{$dirlistref})) {
+ my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) =
+ split(/\&/,$dir_line,16);
+ $item =~ s/\s+$//;
+ next if (($item =~ /^\.\.?$/) || ($obs));
+ if ($dirptr&$testdir) {
+ my $newpath;
+ if ($relpath) {
+ $newpath = "$relpath/$item";
+ } else {
+ $newpath = $item;
+ }
+ $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
+ if ($recurse) {
+ &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
+ }
+ } elsif (($savefile) || ($relpath eq '')) {
+ next if ($nonemptydir && $filecount);
+ if ($checkinc || $checkexc) {
+ my $extension;
+ if ($checkinc) {
+ next unless ($extension && $include->{$extension});
+ }
+ if ($checkexc) {
+ next if ($extension && $exclude->{$extension});
+ }
+ }
+ if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
+ $dirhashref->{'/'} = 1;
+ }
+ if ($savefile) {
+ if ($relpath eq '') {
+ $filehashref->{'/'}{$item} = 1;
+ } else {
+ $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
+ }
+ }
+ $filecount ++;
+ }
+ }
+ }
+ }
+ if ($addtopdir) {
+ if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
+ $dirhashref->{'/'} = 1;
+ }
+ }
+ return;
+}
+
+sub priv_exclude {
+ return {
+ meta => 1,
+ save => 1,
+ log => 1,
+ bak => 1,
+ rights => 1,
+ DS_Store => 1,
+ };
+}
+
# -------------------------------------------------------- Value of a Condition
# gets the value of a specific preevaluated condition
@@ -12038,7 +12744,14 @@ sub get_userresdata {
# Parameters:
# $name - Course/user name.
# $domain - Name of the domain the user/course is registered on.
-# $type - Type of thing $name is (must be 'course' or 'user'
+# $type - Type of thing $name is (must be 'course' or 'user')
+# $mapp - decluttered URL of enclosing map
+# $recursed - Ref to scalar -- set to 1, if nested maps have been recursed.
+# $recurseup - Ref to array of map URLs, starting with map containing
+# $mapp up through hierarchy of nested maps to top level map.
+# $courseid - CourseID (first part of param identifier).
+# $modifier - Middle part of param identifier.
+# $what - Last part of param identifier.
# @which - Array of names of resources desired.
# Returns:
# The value of the first reasource in @which that is found in the
@@ -12048,7 +12761,8 @@ sub get_userresdata {
# 'user', an undefined reference is returned.
# If none of the resources are found, an undef is returned
sub resdata {
- my ($name,$domain,$type,@which)=@_;
+ my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid,
+ $modifier,$what,@which)=@_;
my $result;
if ($type eq 'course') {
$result=&get_courseresdata($name,$domain);
@@ -12057,7 +12771,21 @@ sub resdata {
}
if (!ref($result)) { return $result; }
foreach my $item (@which) {
- if (defined($result->{$item->[0]})) {
+ if ($item->[1] eq 'course') {
+ if ((ref($recurseup) eq 'ARRAY') && (ref($recursed) eq 'SCALAR')) {
+ unless ($$recursed) {
+ @{$recurseup} = &get_map_hierarchy($mapp,$courseid);
+ $$recursed = 1;
+ }
+ foreach my $item (@${recurseup}) {
+ my $norecursechk=$courseid.$modifier.$item.'___(all).'.$what;
+ last if (defined($result->{$norecursechk}));
+ my $recursechk=$courseid.$modifier.$item.'___(rec).'.$what;
+ if (defined($result->{$recursechk})) { return [$result->{$recursechk},'map']; }
+ }
+ }
+ }
+ if (defined($result->{$item->[0]})) {
return [$result->{$item->[0]},$item->[1]];
}
}
@@ -12341,7 +13069,7 @@ sub EXT_cache_set {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;
+ my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
unless ($varname) { return ''; }
#get real user name/domain, courseid and symb
my $courseid;
@@ -12494,23 +13222,26 @@ sub EXT {
}
}
- my ($section, $group, @groups);
- my ($courselevelm,$courselevel);
+ my ($section, $group, @groups, @recurseup, $recursed);
+ if (ref($recurseupref) eq 'ARRAY') {
+ @recurseup = @{$recurseupref};
+ $recursed = 1;
+ }
+ my ($courselevelm,$courseleveli,$courselevel,$mapp);
if (($courseid eq '') && ($cid)) {
$courseid = $cid;
}
if (($symbparm && $courseid) &&
- (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {
+ (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {
#print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
# ----------------------------------------------------- Cascading lookup scheme
my $symbp=$symbparm;
- my $mapp=&deversion((&decode_symb($symbp))[0]);
-
+ $mapp=&deversion((&decode_symb($symbp))[0]);
my $symbparm=$symbp.'.'.$spacequalifierrest;
+ my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
-
if (($env{'user.name'} eq $uname) &&
($env{'user.domain'} eq $udom)) {
$section=$env{'request.course.sec'};
@@ -12527,17 +13258,21 @@ sub EXT {
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
+ my $secleveli=$courseid.'.['.$section.'].'.$recurseparm;
my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
$courselevel=$courseid.'.'.$spacequalifierrest;
my $courselevelr=$courseid.'.'.$symbparm;
+ $courseleveli=$courseid.'.'.$recurseparm;
$courselevelm=$courseid.'.'.$mapparm;
# ----------------------------------------------------------- first, check user
- my $userreply=&resdata($uname,$udom,'user',
+ my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed,
+ \@recurseup,$courseid,'.',$spacequalifierrest,
([$courselevelr,'resource'],
[$courselevelm,'map' ],
+ [$courseleveli,'map' ],
[$courselevel, 'course' ]));
if (defined($userreply)) { return &get_reply($userreply); }
@@ -12545,15 +13280,18 @@ sub EXT {
my $coursereply;
if (@groups > 0) {
$coursereply = &check_group_parms($courseid,\@groups,$symbparm,
- $mapparm,$spacequalifierrest);
- if (defined($coursereply)) { return &get_reply($coursereply); }
+ $recurseparm,$mapparm,$spacequalifierrest,
+ $mapp,\$recursed,\@recurseup);
+ if (defined($coursereply)) { return &get_reply($coursereply); }
}
$coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},
- 'course',
+ 'course',$mapp,\$recursed,\@recurseup,
+ $courseid,'.['.$section.'].',$spacequalifierrest,
([$seclevelr, 'resource'],
[$seclevelm, 'map' ],
+ [$secleveli, 'map' ],
[$seclevel, 'course' ],
[$courselevelr,'resource']));
if (defined($coursereply)) { return &get_reply($coursereply); }
@@ -12570,10 +13308,10 @@ sub EXT {
if ($thisparm) { return &get_reply([$thisparm,'resource']); }
}
# ------------------------------------------ fourth, look in resource metadata
-
+
my $what = $spacequalifierrest;
- $what=~s/\./\_/;
- my $filename;
+ $what=~s/\./\_/;
+ my $filename;
if (!$symbparm) { $symbparm=&symbread(); }
if ($symbparm) {
$filename=(&decode_symb($symbparm))[2];
@@ -12594,8 +13332,10 @@ sub EXT {
$courseid eq $env{'request.course.id'}) {
my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},
- 'course',
+ 'course',$mapp,\$recursed,\@recurseup,
+ $courseid,'.',$spacequalifierrest,
([$courselevelm,'map' ],
+ [$courseleveli,'map' ],
[$courselevel, 'course']));
if (defined($coursereply)) { return &get_reply($coursereply); }
}
@@ -12656,19 +13396,24 @@ sub get_reply {
}
sub check_group_parms {
- my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
- my @groupitems = ();
- my $resultitem;
- my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
+ my ($courseid,$groups,$symbparm,$recurseparm,$mapparm,$what,$mapp,
+ $recursed,$recurseupref) = @_;
+ my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$recurseparm,'map'],
+ [$what,'course']);
+ my $coursereply;
foreach my $group (@{$groups}) {
+ my @groupitems = ();
foreach my $level (@levels) {
my $item = $courseid.'.['.$group.'].'.$level->[0];
push(@groupitems,[$item,$level->[1]]);
}
+ my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
+ $env{'course.'.$courseid.'.domain'},
+ 'course',$mapp,$recursed,$recurseupref,
+ $courseid,'.['.$group.'].',$what,
+ @groupitems);
+ last if (defined($coursereply));
}
- my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
- $env{'course.'.$courseid.'.domain'},
- 'course',@groupitems);
return $coursereply;
}
@@ -12815,11 +13560,11 @@ sub metadata {
# gradable in the exttool_$marker.db file for the tool instance
# is retrieved via &get().
#
-# When lonuserstate::traceroute() calls lonnet::EXT() for
+# When lonuserstate::traceroute() calls lonnet::EXT() for
# hiddenresource and encrypturl (during course initialization)
-# the map-level parameter for resource.0.gradable included in the
+# the map-level parameter for resource.0.gradable included in the
# uploaded map containing the tool will not yet have been stored
-# in the user_course_parms.db file for the user's session, so in
+# in the user_course_parms.db file for the user's session, so in
# this case fall back to retrieving gradable status from the
# exttool_$marker.db file.
#
@@ -12967,23 +13712,31 @@ sub metadata {
# Check metadata for imported file to
# see if it contained response items
#
+ my ($origfile,@libfilekeys);
my %currmetaentry = %metaentry;
- my $libresponseorder = &metadata($location,'responseorder');
- my $origfile;
- if ($libresponseorder ne '') {
- if ($#origfiletagids<0) {
- undef(%importedrespids);
- undef(%importedpartids);
- }
- @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder);
- if (@{$importedrespids{$importid}} > 0) {
- $importedresponses = 1;
+ @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
+ $depthcount+1));
+ if (grep(/^responseorder$/,@libfilekeys)) {
+ my $libresponseorder = &metadata($location,'responseorder',undef,undef,
+ undef,$depthcount+1);
+ if ($libresponseorder ne '') {
+ if ($#origfiletagids<0) {
+ undef(%importedrespids);
+ undef(%importedpartids);
+ }
+ my @respids = split(/\s*,\s*/,$libresponseorder);
+ if (@respids) {
+ $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids);
+ }
+ if ($importedrespids{$importid} ne '') {
+ $importedresponses = 1;
# We need to get the original file and the imported file to get the response order correct
# Load and inspect original file
- if ($#origfiletagids<0) {
- my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
- $origfile=&getfile($origfilelocation);
- @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ if ($#origfiletagids<0) {
+ my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+ $origfile=&getfile($origfilelocation);
+ @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ }
}
}
}
@@ -12991,10 +13744,7 @@ sub metadata {
# hash populated for imported library file
%metaentry = %currmetaentry;
undef(%currmetaentry);
- if ($importmode eq 'problem') {
-# Import as problem/response
- $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
- } elsif ($importmode eq 'part') {
+ if ($importmode eq 'part') {
# Import as part(s)
$importedparts=1;
# We need to get the original file and the imported file to get the part order correct
@@ -13009,10 +13759,23 @@ sub metadata {
@origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
}
}
-
-# Load and inspect imported file
- my $impfile=&getfile($location);
- my @impfilepartids=($impfile=~/