|
version 1.1332, 2017/01/02 19:44:20
|
version 1.1370, 2018/03/30 18:07:47
|
|
Line 71 delayed.
|
Line 71 delayed.
|
| package Apache::lonnet; |
package Apache::lonnet; |
| |
|
| use strict; |
use strict; |
| use LWP::UserAgent(); |
|
| use HTTP::Date; |
use HTTP::Date; |
| use Image::Magick; |
use Image::Magick; |
| |
|
|
Line 101 use LONCAPA qw(:DEFAULT :match);
|
Line 100 use LONCAPA qw(:DEFAULT :match);
|
| use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
| use LONCAPA::lonmetadata; |
use LONCAPA::lonmetadata; |
| use LONCAPA::Lond; |
use LONCAPA::Lond; |
| |
use LONCAPA::LWPReq; |
| |
|
| use File::Copy; |
use File::Copy; |
| |
|
|
Line 146 our @EXPORT = qw(%env);
|
Line 146 our @EXPORT = qw(%env);
|
| sub logtouch { |
sub logtouch { |
| my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
| unless (-e "$execdir/logs/lonnet.log") { |
unless (-e "$execdir/logs/lonnet.log") { |
| open(my $fh,">>$execdir/logs/lonnet.log"); |
open(my $fh,">>","$execdir/logs/lonnet.log"); |
| close $fh; |
close $fh; |
| } |
} |
| my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; |
my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; |
|
Line 158 sub logthis {
|
Line 158 sub logthis {
|
| my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
| my $now=time; |
my $now=time; |
| my $local=localtime($now); |
my $local=localtime($now); |
| if (open(my $fh,">>$execdir/logs/lonnet.log")) { |
if (open(my $fh,">>","$execdir/logs/lonnet.log")) { |
| my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. |
my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. |
| print $fh $logstring; |
print $fh $logstring; |
| close($fh); |
close($fh); |
|
Line 171 sub logperm {
|
Line 171 sub logperm {
|
| my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
| my $now=time; |
my $now=time; |
| my $local=localtime($now); |
my $local=localtime($now); |
| if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { |
if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) { |
| print $fh "$now:$message:$local\n"; |
print $fh "$now:$message:$local\n"; |
| close($fh); |
close($fh); |
| } |
} |
|
Line 243 sub get_servercerts_info {
|
Line 243 sub get_servercerts_info {
|
| if ($1 < 6) { |
if ($1 < 6) { |
| $uselocal = 0; |
$uselocal = 0; |
| } |
} |
| |
} elsif ($distro =~ /^(?:sles)(\d+)$/) { |
| |
if ($1 < 12) { |
| |
$uselocal = 0; |
| |
} |
| } |
} |
| } |
} |
| if ($uselocal) { |
if ($uselocal) { |
|
Line 305 sub get_server_loncaparev {
|
Line 309 sub get_server_loncaparev {
|
| $answer = &reply('serverloncaparev',$lonhost); |
$answer = &reply('serverloncaparev',$lonhost); |
| if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { |
if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { |
| if ($caller eq 'loncron') { |
if ($caller eq 'loncron') { |
| my $ua=new LWP::UserAgent; |
|
| $ua->timeout(4); |
|
| my $protocol = $protocol{$lonhost}; |
my $protocol = $protocol{$lonhost}; |
| $protocol = 'http' if ($protocol ne 'https'); |
$protocol = 'http' if ($protocol ne 'https'); |
| my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; |
my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; |
| my $request=new HTTP::Request('GET',$url); |
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()) { |
unless ($response->is_error()) { |
| my $content = $response->content; |
my $content = $response->content; |
| if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) { |
if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) { |
|
Line 483 sub reconlonc {
|
Line 485 sub reconlonc {
|
| |
|
| &logthis("Trying to reconnect lonc"); |
&logthis("Trying to reconnect lonc"); |
| my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
| if (open(my $fh,"<$loncfile")) { |
if (open(my $fh,"<",$loncfile)) { |
| my $loncpid=<$fh>; |
my $loncpid=<$fh>; |
| chomp($loncpid); |
chomp($loncpid); |
| if (kill 0 => $loncpid) { |
if (kill 0 => $loncpid) { |
|
Line 523 sub critical {
|
Line 525 sub critical {
|
| $dumpcount++; |
$dumpcount++; |
| { |
{ |
| my $dfh; |
my $dfh; |
| if (open($dfh,">$dfilename")) { |
if (open($dfh,">",$dfilename)) { |
| print $dfh "$cmd\n"; |
print $dfh "$cmd\n"; |
| close($dfh); |
close($dfh); |
| } |
} |
|
Line 532 sub critical {
|
Line 534 sub critical {
|
| my $wcmd=''; |
my $wcmd=''; |
| { |
{ |
| my $dfh; |
my $dfh; |
| if (open($dfh,"<$dfilename")) { |
if (open($dfh,"<",$dfilename)) { |
| $wcmd=<$dfh>; |
$wcmd=<$dfh>; |
| close($dfh); |
close($dfh); |
| } |
} |
|
Line 648 sub transfer_profile_to_env {
|
Line 650 sub transfer_profile_to_env {
|
| |
|
| # ---------------------------------------------------- Check for valid session |
# ---------------------------------------------------- Check for valid session |
| sub check_for_valid_session { |
sub check_for_valid_session { |
| my ($r,$name,$userhashref) = @_; |
my ($r,$name,$userhashref,$domref) = @_; |
| my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
| |
my ($linkname,$pubname); |
| if ($name eq '') { |
if ($name eq '') { |
| $name = 'lonID'; |
$name = 'lonID'; |
| |
$linkname = 'lonLinkID'; |
| |
$pubname = 'lonPubID'; |
| } |
} |
| my $lonid=$cookies{$name}; |
my $lonid=$cookies{$name}; |
| |
if (!$lonid) { |
| |
if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) { |
| |
$lonid=$cookies{$linkname}; |
| |
} |
| |
if (!$lonid) { |
| |
if (($name eq 'lonID') && ($pubname)) { |
| |
$lonid=$cookies{$pubname}; |
| |
} |
| |
} |
| |
} |
| return undef if (!$lonid); |
return undef if (!$lonid); |
| |
|
| my $handle=&LONCAPA::clean_handle($lonid->value); |
my $handle=&LONCAPA::clean_handle($lonid->value); |
|
Line 663 sub check_for_valid_session {
|
Line 678 sub check_for_valid_session {
|
| } else { |
} else { |
| $lonidsdir=$r->dir_config('lonIDsDir'); |
$lonidsdir=$r->dir_config('lonIDsDir'); |
| } |
} |
| return undef if (!-e "$lonidsdir/$handle.id"); |
if (!-e "$lonidsdir/$handle.id") { |
| |
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)) { |
| |
$$domref = $possudom; |
| |
} |
| |
} |
| |
return undef; |
| |
} |
| |
|
| my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
| return undef if (!$opened); |
return undef if (!$opened); |
|
Line 683 sub check_for_valid_session {
|
Line 707 sub check_for_valid_session {
|
| if (ref($userhashref) eq 'HASH') { |
if (ref($userhashref) eq 'HASH') { |
| $userhashref->{'name'} = $disk_env{'user.name'}; |
$userhashref->{'name'} = $disk_env{'user.name'}; |
| $userhashref->{'domain'} = $disk_env{'user.domain'}; |
$userhashref->{'domain'} = $disk_env{'user.domain'}; |
| |
$userhashref->{'lti'} = $disk_env{'request.lti.login'}; |
| } |
} |
| |
|
| return $handle; |
return $handle; |
|
Line 1583 sub internet_dom_servers {
|
Line 1608 sub internet_dom_servers {
|
| return %uniqservers; |
return %uniqservers; |
| } |
} |
| |
|
| |
sub trusted_domains { |
| |
my ($cmdtype,$calldom) = @_; |
| |
my ($trusted,$untrusted); |
| |
if (&domain($calldom) eq '') { |
| |
return ($trusted,$untrusted); |
| |
} |
| |
unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) { |
| |
return ($trusted,$untrusted); |
| |
} |
| |
my $callprimary = &domain($calldom,'primary'); |
| |
my $intcalldom = &Apache::lonnet::internet_dom($callprimary); |
| |
if ($intcalldom eq '') { |
| |
return ($trusted,$untrusted); |
| |
} |
| |
|
| |
my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom); |
| |
unless (defined($cached)) { |
| |
my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom); |
| |
&Apache::lonnet::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') { |
| |
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') { |
| |
$untrusted = $doms_by_intdom{$exc}; |
| |
} |
| |
} |
| |
foreach my $inc (@allinc) { |
| |
if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { |
| |
$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 |
# ---------------------- Find the homebase for a user from domain's lib servers |
| |
|
| my %homecache; |
my %homecache; |
|
Line 1832 sub get_dom {
|
Line 1951 sub get_dom {
|
| } |
} |
| } |
} |
| if ($udom && $uhome && ($uhome ne 'no_host')) { |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
| my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
my $rep; |
| |
if ($namespace =~ /^enc/) { |
| |
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); |
| |
} else { |
| |
$rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
| |
} |
| my %returnhash; |
my %returnhash; |
| if ($rep eq '' || $rep =~ /^error: 2 /) { |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
| return %returnhash; |
return %returnhash; |
|
Line 1876 sub put_dom {
|
Line 2000 sub put_dom {
|
| $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
| } |
} |
| $items=~s/\&$//; |
$items=~s/\&$//; |
| return &reply("putdom:$udom:$namespace:$items",$uhome); |
if ($namespace =~ /^enc/) { |
| |
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); |
| |
} else { |
| |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
| |
} |
| } else { |
} else { |
| &logthis("put_dom failed - no homeserver and/or domain"); |
&logthis("put_dom failed - no homeserver and/or domain"); |
| } |
} |
|
Line 1967 sub inst_directory_query {
|
Line 2095 sub inst_directory_query {
|
| my $homeserver = &domain($udom,'primary'); |
my $homeserver = &domain($udom,'primary'); |
| my $outcome; |
my $outcome; |
| if ($homeserver ne '') { |
if ($homeserver ne '') { |
| |
unless ($homeserver eq $perlvar{'lonHostID'}) { |
| |
if ($srch->{'srchby'} eq 'email') { |
| |
my $lcrev = &get_server_loncaparev(undef,$homeserver); |
| |
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
| |
if (($major eq '' && $minor eq '') || ($major < 2) || |
| |
(($major == 2) && ($minor < 12))) { |
| |
return; |
| |
} |
| |
} |
| |
} |
| my $queryid=&reply("querysend:instdirsearch:". |
my $queryid=&reply("querysend:instdirsearch:". |
| &escape($srch->{'srchby'}).':'. |
&escape($srch->{'srchby'}).':'. |
| &escape($srch->{'srchterm'}).':'. |
&escape($srch->{'srchterm'}).':'. |
| &escape($srch->{'srchtype'}),$homeserver); |
&escape($srch->{'srchtype'}),$homeserver); |
| my $host=&hostname($homeserver); |
my $host=&hostname($homeserver); |
| if ($queryid !~/^\Q$host\E\_/) { |
if ($queryid !~/^\Q$host\E\_/) { |
| &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); |
&logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom); |
| return; |
return; |
| } |
} |
| my $response = &get_query_reply($queryid); |
my $response = &get_query_reply($queryid); |
|
Line 2008 sub usersearch {
|
Line 2146 sub usersearch {
|
| my $query = 'usersearch'; |
my $query = 'usersearch'; |
| foreach my $tryserver (keys(%libserv)) { |
foreach my $tryserver (keys(%libserv)) { |
| if (&host_domain($tryserver) eq $dom) { |
if (&host_domain($tryserver) eq $dom) { |
| |
unless ($tryserver eq $perlvar{'lonHostID'}) { |
| |
if ($srch->{'srchby'} eq 'email') { |
| |
my $lcrev = &get_server_loncaparev(undef,$tryserver); |
| |
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
| |
next if (($major eq '' && $minor eq '') || ($major < 2) || |
| |
(($major == 2) && ($minor < 12))); |
| |
} |
| |
} |
| my $host=&hostname($tryserver); |
my $host=&hostname($tryserver); |
| my $queryid= |
my $queryid= |
| &reply("querysend:".&escape($query).':'. |
&reply("querysend:".&escape($query).':'. |
|
Line 2256 sub get_domain_defaults {
|
Line 2402 sub get_domain_defaults {
|
| $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
| $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
| $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
| |
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; |
| |
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; |
| |
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; |
| } else { |
} else { |
| $domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
| $domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
|
Line 2323 sub get_domain_defaults {
|
Line 2472 sub get_domain_defaults {
|
| } elsif ($domconfig{'coursedefaults'}{'canclone'}) { |
} elsif ($domconfig{'coursedefaults'}{'canclone'}) { |
| $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; |
$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; |
| } |
} |
| |
if ($domconfig{'coursedefaults'}{'texengine'}) { |
| |
$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'}; |
| |
} |
| } |
} |
| if (ref($domconfig{'usersessions'}) eq 'HASH') { |
if (ref($domconfig{'usersessions'}) eq 'HASH') { |
| if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { |
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { |
|
Line 2377 sub get_domain_defaults {
|
Line 2529 sub get_domain_defaults {
|
| if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { |
if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { |
| $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; |
$domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; |
| } |
} |
| if (ref($domconfig{'ssl'}{'connect'}) eq 'HASH') { |
if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') { |
| $domdefaults{'connect'} = $domconfig{'ssl'}{'connect'}; |
$domdefaults{'connect'} = $domconfig{'ssl'}{'connto'}; |
| |
} |
| |
if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') { |
| |
$domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'}; |
| } |
} |
| } |
} |
| if (ref($domconfig{'trust'}) eq 'HASH') { |
if (ref($domconfig{'trust'}) eq 'HASH') { |
|
Line 2925 sub repcopy {
|
Line 3080 sub repcopy {
|
| mkdir($path,0777); |
mkdir($path,0777); |
| } |
} |
| } |
} |
| my $ua=new LWP::UserAgent; |
|
| my $request=new HTTP::Request('GET',"$remoteurl"); |
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()) { |
if ($response->is_error()) { |
| unlink($transname); |
unlink($transname); |
| my $message=$response->status_line; |
my $message=$response->status_line; |
|
Line 2937 sub repcopy {
|
Line 3096 sub repcopy {
|
| } else { |
} else { |
| if ($remoteurl!~/\.meta$/) { |
if ($remoteurl!~/\.meta$/) { |
| my $mrequest=new HTTP::Request('GET',$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()) { |
if ($mresponse->is_error()) { |
| unlink($filename.'.meta'); |
unlink($filename.'.meta'); |
| &logthis( |
&logthis( |
|
Line 3000 sub absolute_url {
|
Line 3164 sub absolute_url {
|
| sub ssi { |
sub ssi { |
| |
|
| my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
| my $ua=new LWP::UserAgent; |
|
| my $request; |
my $request; |
| |
|
| $form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
|
Line 3018 sub ssi {
|
Line 3181 sub ssi {
|
| } |
} |
| |
|
| $request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
| my $response= $ua->request($request); |
my $lonhost = $perlvar{'lonHostID'}; |
| my $content = $response->content; |
my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar); |
| |
|
| |
|
| if (wantarray) { |
if (wantarray) { |
| return ($content, $response); |
return ($response->content, $response); |
| } else { |
} else { |
| return $content; |
return $response->content; |
| } |
} |
| } |
} |
| |
|
| sub externalssi { |
sub externalssi { |
| my ($url)=@_; |
my ($url)=@_; |
| my $ua=new LWP::UserAgent; |
|
| my $request=new HTTP::Request('GET',$url); |
my $request=new HTTP::Request('GET',$url); |
| my $response=$ua->request($request); |
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar); |
| if (wantarray) { |
if (wantarray) { |
| return ($response->content, $response); |
return ($response->content, $response); |
| } else { |
} else { |
|
Line 3041 sub externalssi {
|
Line 3202 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 |
| |
# happens, remove local copies of outdated resource (and corresponding |
| |
# metadata file). |
| |
|
| |
sub remove_stale_resfile { |
| |
my ($url) = @_; |
| |
my $removed; |
| |
if ($url=~m{^/res/($match_domain)/($match_username)/}) { |
| |
my $audom = $1; |
| |
my $auname = $2; |
| |
unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) { |
| |
my $homeserver = &homeserver($auname,$audom); |
| |
unless (($homeserver eq 'no_host') || |
| |
(grep { $_ eq $homeserver } ¤t_machine_ids())) { |
| |
my $fname = &filelocation('',$url); |
| |
if (-e $fname) { |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
my $hostname = &hostname($homeserver); |
| |
if ($hostname) { |
| |
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]; |
| |
if ($locmodtime < $remmodtime) { |
| |
my $stale; |
| |
my $answer = &reply('pong',$homeserver); |
| |
if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) { |
| |
sleep(0.2); |
| |
$locmodtime = (stat($fname))[9]; |
| |
if ($locmodtime < $remmodtime) { |
| |
my $posstransfer = $fname.'.in.transfer'; |
| |
if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) { |
| |
$removed = 1; |
| |
} else { |
| |
$stale = 1; |
| |
} |
| |
} else { |
| |
$removed = 1; |
| |
} |
| |
} else { |
| |
$stale = 1; |
| |
} |
| |
if ($stale) { |
| |
unlink($fname); |
| |
if ($uri!~/\.meta$/) { |
| |
unlink($fname.'.meta'); |
| |
} |
| |
&reply("unsub:$fname",$homeserver); |
| |
$removed = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $removed; |
| |
} |
| |
|
| # -------------------------------- Allow a /uploaded/ URI to be vouched for |
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
| |
|
| sub allowuploaded { |
sub allowuploaded { |
|
Line 3179 sub can_edit_resource {
|
Line 3405 sub can_edit_resource {
|
| $forceedit = 1; |
$forceedit = 1; |
| } |
} |
| $cfile = $resurl; |
$cfile = $resurl; |
| } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) { |
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
| $incourse = 1; |
$incourse = 1; |
| if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
| $forceview = 1; |
$forceview = 1; |
|
Line 3211 sub can_edit_resource {
|
Line 3437 sub can_edit_resource {
|
| $forceedit = 1; |
$forceedit = 1; |
| } |
} |
| $cfile = $resurl; |
$cfile = $resurl; |
| } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
| $incourse = 1; |
$incourse = 1; |
| if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
| $forceview = 1; |
$forceview = 1; |
|
Line 3229 sub can_edit_resource {
|
Line 3455 sub can_edit_resource {
|
| } else { |
} else { |
| $cfile = $env{'form.suppurl'}; |
$cfile = $env{'form.suppurl'}; |
| my $escfile = &unescape($cfile); |
my $escfile = &unescape($cfile); |
| if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) { |
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
| $cfile = '/adm/wrapper'.$escfile; |
$cfile = '/adm/wrapper'.$escfile; |
| } else { |
} else { |
| $escfile =~ s{^http://}{}; |
$escfile =~ s{^http://}{}; |
|
Line 3390 sub process_coursefile {
|
Line 3616 sub process_coursefile {
|
| $home); |
$home); |
| } |
} |
| } elsif ($action eq 'uploaddoc') { |
} elsif ($action eq 'uploaddoc') { |
| open(my $fh,'>'.$filepath.'/'.$fname); |
open(my $fh,'>',$filepath.'/'.$fname); |
| print $fh $env{'form.'.$source}; |
print $fh $env{'form.'.$source}; |
| close($fh); |
close($fh); |
| if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
|
Line 3448 sub store_edited_file {
|
Line 3674 sub store_edited_file {
|
| ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
| $fpath=$docudom.'/'.$docuname.'/'.$fpath; |
$fpath=$docudom.'/'.$docuname.'/'.$fpath; |
| my $filepath = &build_filepath($fpath); |
my $filepath = &build_filepath($fpath); |
| open(my $fh,'>'.$filepath.'/'.$fname); |
open(my $fh,'>',$filepath.'/'.$fname); |
| print $fh $content; |
print $fh $content; |
| close($fh); |
close($fh); |
| my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
|
Line 3564 sub userfileupload {
|
Line 3790 sub userfileupload {
|
| '_'.$env{'user.domain'}.'/pending'; |
'_'.$env{'user.domain'}.'/pending'; |
| } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { |
} elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { |
| my ($docuname,$docudom); |
my ($docuname,$docudom); |
| if ($destudom) { |
if ($destudom =~ /^$match_domain$/) { |
| $docudom = $destudom; |
$docudom = $destudom; |
| } else { |
} else { |
| $docudom = $env{'user.domain'}; |
$docudom = $env{'user.domain'}; |
| } |
} |
| if ($destuname) { |
if ($destuname =~ /^$match_username$/) { |
| $docuname = $destuname; |
$docuname = $destuname; |
| } else { |
} else { |
| $docuname = $env{'user.name'}; |
$docuname = $env{'user.name'}; |
|
Line 3599 sub userfileupload {
|
Line 3825 sub userfileupload {
|
| mkdir($fullpath,0777); |
mkdir($fullpath,0777); |
| } |
} |
| } |
} |
| open(my $fh,'>'.$fullpath.'/'.$fname); |
open(my $fh,'>',$fullpath.'/'.$fname); |
| print $fh $env{'form.'.$formname}; |
print $fh $env{'form.'.$formname}; |
| close($fh); |
close($fh); |
| if ($context eq 'existingfile') { |
if ($context eq 'existingfile') { |
|
Line 3674 sub finishuserfileupload {
|
Line 3900 sub finishuserfileupload {
|
| |
|
| # Save the file |
# Save the file |
| { |
{ |
| if (!open(FH,'>'.$filepath.'/'.$file)) { |
if (!open(FH,'>',$filepath.'/'.$file)) { |
| &logthis('Failed to create '.$filepath.'/'.$file); |
&logthis('Failed to create '.$filepath.'/'.$file); |
| print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); |
print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
|
Line 3732 sub finishuserfileupload {
|
Line 3958 sub finishuserfileupload {
|
| my $input = $filepath.'/'.$file; |
my $input = $filepath.'/'.$file; |
| my $output = $filepath.'/'.'tn-'.$file; |
my $output = $filepath.'/'.'tn-'.$file; |
| my $thumbsize = $thumbwidth.'x'.$thumbheight; |
my $thumbsize = $thumbwidth.'x'.$thumbheight; |
| system("convert -sample $thumbsize $input $output"); |
my @args = ('convert','-sample',$thumbsize,$input,$output); |
| |
system({$args[0]} @args); |
| if (-e $filepath.'/'.'tn-'.$file) { |
if (-e $filepath.'/'.'tn-'.$file) { |
| $fetchthumb = 1; |
$fetchthumb = 1; |
| } |
} |
|
Line 4116 sub flushcourselogs {
|
Line 4343 sub flushcourselogs {
|
| } |
} |
| } |
} |
| # |
# |
| # Reverse lookup of domain roles (dc, ad, li, sc, dh, au) |
# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au) |
| # |
# |
| my %domrolebuffer = (); |
my %domrolebuffer = (); |
| foreach my $entry (keys(%domainrolehash)) { |
foreach my $entry (keys(%domainrolehash)) { |
|
Line 4263 sub userrolelog {
|
Line 4490 sub userrolelog {
|
| {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
| =$tend.':'.$tstart; |
=$tend.':'.$tstart; |
| } |
} |
| if ($trole =~ /^(dc|ad|li|au|dg|sc|dh)/ ) { |
if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) { |
| my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
| $domainrolehash |
$domainrolehash |
| {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
|
Line 4490 sub get_my_roles {
|
Line 4717 sub get_my_roles {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub get_all_adhocroles { |
| |
my ($dom) = @_; |
| |
my @roles_by_num = (); |
| |
my %domdefaults = &get_domain_defaults($dom); |
| |
my (%description,%access_in_dom,%access_info); |
| |
if (ref($domdefaults{'adhocroles'}) eq 'HASH') { |
| |
my $count = 0; |
| |
my %domcurrent = %{$domdefaults{'adhocroles'}}; |
| |
my %ordered; |
| |
foreach my $role (sort(keys(%domcurrent))) { |
| |
my ($order,$desc,$access_in_dom); |
| |
if (ref($domcurrent{$role}) eq 'HASH') { |
| |
$order = $domcurrent{$role}{'order'}; |
| |
$desc = $domcurrent{$role}{'desc'}; |
| |
$access_in_dom{$role} = $domcurrent{$role}{'access'}; |
| |
$access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}}; |
| |
} |
| |
if ($order eq '') { |
| |
$order = $count; |
| |
} |
| |
$ordered{$order} = $role; |
| |
if ($desc ne '') { |
| |
$description{$role} = $desc; |
| |
} else { |
| |
$description{$role}= $role; |
| |
} |
| |
$count++; |
| |
} |
| |
foreach my $item (sort {$a <=> $b } (keys(%ordered))) { |
| |
push(@roles_by_num,$ordered{$item}); |
| |
} |
| |
} |
| |
return (\@roles_by_num,\%description,\%access_in_dom,\%access_info); |
| |
} |
| |
|
| sub get_my_adhocroles { |
sub get_my_adhocroles { |
| my ($cid) = @_; |
my ($cid,$checkreg) = @_; |
| my (@possroles,%description); |
my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num); |
| if ($cid =~ /^($match_domain)_($match_courseid)$/) { |
if ($env{'request.course.id'} eq $cid) { |
| my $cdom = $1; |
$cdom = $env{'course.'.$cid.'.domain'}; |
| my $cnum = $2; |
$cnum = $env{'course.'.$cid.'.num'}; |
| if ($env{"user.role.dh./$cdom/"}) { |
$info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'}; |
| |
} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) { |
| |
$cdom = $1; |
| |
$cnum = $2; |
| |
%info = &Apache::lonnet::get('environment',['internal.coursecode'], |
| |
$cdom,$cnum); |
| |
} |
| |
if (($info{'internal.coursecode'} ne '') && ($checkreg)) { |
| |
my $user = $env{'user.name'}.':'.$env{'user.domain'}; |
| |
my %rosterhash = &get('classlist',[$user],$cdom,$cnum); |
| |
if ($rosterhash{$user} ne '') { |
| |
my $type = (split(/:/,$rosterhash{$user}))[5]; |
| |
return ([],{}) if ($type eq 'auto'); |
| |
} |
| |
} |
| |
if (($cdom ne '') && ($cnum ne '')) { |
| |
if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) { |
| my $then=$env{'user.login.time'}; |
my $then=$env{'user.login.time'}; |
| my $update=$env{'user.update.time'}; |
my $update=$env{'user.update.time'}; |
| my $liverole = 1; |
if (!$update) { |
| my ($tstart,$tend)=split(/\./,$env{'user.role.dh./'.$cdom}); |
$update = $then; |
| my $limit = $update; |
} |
| if ($env{'request.role'} eq 'dh./'.$cdom.'/') { |
my @liveroles; |
| $limit = $then; |
foreach my $role ('dh','da') { |
| } |
if ($env{"user.role.$role./$cdom/"}) { |
| if ($tstart && $tstart>$limit) { $liverole = 0; } |
my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"}); |
| if ($tend && $tend <$limit) { $liverole = 0; } |
my $limit = $update; |
| if ($liverole) { |
if ($env{'request.role'} eq "$role./$cdom/") { |
| |
$limit = $then; |
| |
} |
| |
my $activerole = 1; |
| |
if ($tstart && $tstart>$limit) { $activerole = 0; } |
| |
if ($tend && $tend <$limit) { $activerole = 0; } |
| |
if ($activerole) { |
| |
push(@liveroles,$role); |
| |
} |
| |
} |
| |
} |
| |
if (@liveroles) { |
| if (&homeserver($cnum,$cdom) ne 'no_host') { |
if (&homeserver($cnum,$cdom) ne 'no_host') { |
| my %domdefaults = &get_domain_defaults($cdom); |
my ($accessref,$accessinfo,%access_in_dom); |
| if (ref($domdefaults{'adhocroles'}) eq 'HASH') { |
($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); |
| my $count = 0; |
if (ref($roles_by_num) eq 'ARRAY') { |
| my %domcurrent = %{$domdefaults{'adhocroles'}}; |
if (@{$roles_by_num}) { |
| my (%ordered,%access_in_dom); |
|
| foreach my $role (sort(keys(%domcurrent))) { |
|
| my ($order,$desc,$access_in_dom); |
|
| if (ref($domcurrent{$role}) eq 'HASH') { |
|
| $order = $domcurrent{$role}{'order'}; |
|
| $desc = $domcurrent{$role}{'desc'}; |
|
| $access_in_dom{$role} = $domcurrent{$role}{'access'}; |
|
| } |
|
| if ($order eq '') { |
|
| $order = $count; |
|
| } |
|
| $ordered{$order} = $role; |
|
| if ($desc ne '') { |
|
| $description{$role} = $desc; |
|
| } else { |
|
| $description{$role}= $role; |
|
| } |
|
| $count++; |
|
| } |
|
| my @roles_by_num = (); |
|
| foreach my $item (sort {$a <=> $b } (keys(%ordered))) { |
|
| push(@roles_by_num,$ordered{$item}); |
|
| } |
|
| if (@roles_by_num) { |
|
| my %settings; |
my %settings; |
| if ($env{'request.course.id'} eq $cid) { |
if ($env{'request.course.id'} eq $cid) { |
| foreach my $envkey (keys(%env)) { |
foreach my $envkey (keys(%env)) { |
|
Line 4556 sub get_my_adhocroles {
|
Line 4821 sub get_my_adhocroles {
|
| @statuses = split(/,/,$env{'environment.inststatus'}); |
@statuses = split(/,/,$env{'environment.inststatus'}); |
| } |
} |
| my $user = $env{'user.name'}.':'.$env{'user.domain'}; |
my $user = $env{'user.name'}.':'.$env{'user.domain'}; |
| foreach my $role (@roles_by_num) { |
if (ref($accessref) eq 'HASH') { |
| |
%access_in_dom = %{$accessref}; |
| |
} |
| |
foreach my $role (@{$roles_by_num}) { |
| my ($curraccess,@okstatus,@personnel); |
my ($curraccess,@okstatus,@personnel); |
| if ($setincrs{$role}) { |
if ($setincrs{$role}) { |
| ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role}); |
($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role}); |
|
Line 4567 sub get_my_adhocroles {
|
Line 4835 sub get_my_adhocroles {
|
| } |
} |
| } else { |
} else { |
| $curraccess = $access_in_dom{$role}; |
$curraccess = $access_in_dom{$role}; |
| if ($curraccess eq 'status') { |
if (ref($accessinfo) eq 'HASH') { |
| if (ref($domcurrent{$role}{$curraccess}) eq 'ARRAY') { |
if ($curraccess eq 'status') { |
| @okstatus = @{$domcurrent{$role}{$curraccess}}; |
if (ref($accessinfo->{$role}) eq 'ARRAY') { |
| } |
@okstatus = @{$accessinfo->{$role}}; |
| } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { |
} |
| if (ref($domcurrent{$role}{$curraccess}) eq 'ARRAY') { |
} elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { |
| @personnel = @{$domcurrent{$role}{$curraccess}}; |
if (ref($accessinfo->{$role}) eq 'ARRAY') { |
| |
@personnel = @{$accessinfo->{$role}}; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 4581 sub get_my_adhocroles {
|
Line 4851 sub get_my_adhocroles {
|
| next; |
next; |
| } elsif ($curraccess eq 'all') { |
} elsif ($curraccess eq 'all') { |
| push(@possroles,$role); |
push(@possroles,$role); |
| |
} elsif ($curraccess eq 'dh') { |
| |
if (grep(/^dh$/,@liveroles)) { |
| |
push(@possroles,$role); |
| |
} else { |
| |
next; |
| |
} |
| |
} elsif ($curraccess eq 'da') { |
| |
if (grep(/^da$/,@liveroles)) { |
| |
push(@possroles,$role); |
| |
} else { |
| |
next; |
| |
} |
| } elsif ($curraccess eq 'status') { |
} elsif ($curraccess eq 'status') { |
| if (@okstatus) { |
if (@okstatus) { |
| if (!@statuses) { |
if (!@statuses) { |
|
Line 4612 sub get_my_adhocroles {
|
Line 4894 sub get_my_adhocroles {
|
| } |
} |
| } |
} |
| } |
} |
| return (\@possroles,\%description); |
unless (ref($description) eq 'HASH') { |
| |
if (ref($roles_by_num) eq 'ARRAY') { |
| |
my %desc; |
| |
map { $desc{$_} = $_; } (@{$roles_by_num}); |
| |
$description = \%desc; |
| |
} else { |
| |
$description = {}; |
| |
} |
| |
} |
| |
return (\@possroles,$description); |
| } |
} |
| |
|
| # ----------------------------------------------------- Frontpage Announcements |
# ----------------------------------------------------- Frontpage Announcements |
|
Line 4628 sub postannounce {
|
Line 4919 sub postannounce {
|
| |
|
| sub getannounce { |
sub getannounce { |
| |
|
| if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { |
if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) { |
| my $announcement=''; |
my $announcement=''; |
| while (my $line = <$fh>) { $announcement .= $line; } |
while (my $line = <$fh>) { $announcement .= $line; } |
| close($fh); |
close($fh); |
|
Line 4938 sub set_first_access {
|
Line 5229 sub set_first_access {
|
| 'course.'.$courseid.'.timerinterval.'.$res => $interval, |
'course.'.$courseid.'.timerinterval.'.$res => $interval, |
| } |
} |
| ); |
); |
| |
if (($cachedtime) && (abs($start-$cachedtime) < 5)) { |
| |
$cachedtimes{"$courseid\0$res"} = $start; |
| |
} |
| } |
} |
| return $putres; |
return $putres; |
| } |
} |
|
Line 5724 sub rolesinit {
|
Line 6018 sub rolesinit {
|
| } |
} |
| } |
} |
| |
|
| @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles, |
@userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, |
| \%allroles, \%allgroups); |
\%allroles, \%allgroups); |
| $env{'user.adv'} = $userroles{'user.adv'}; |
$env{'user.adv'} = $userroles{'user.adv'}; |
| |
$env{'user.rar'} = $userroles{'user.rar'}; |
| |
|
| return (\%userroles,\%firstaccenv,\%timerintenv); |
return (\%userroles,\%firstaccenv,\%timerintenv); |
| } |
} |
|
Line 5850 sub set_userprivs {
|
Line 6145 sub set_userprivs {
|
| my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
| my $author=0; |
my $author=0; |
| my $adv=0; |
my $adv=0; |
| |
my $rar=0; |
| my %grouproles = (); |
my %grouproles = (); |
| if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
| my @groupkeys; |
my @groupkeys; |
|
Line 5897 sub set_userprivs {
|
Line 6193 sub set_userprivs {
|
| $thesepriv{$privilege}.=$restrictions; |
$thesepriv{$privilege}.=$restrictions; |
| } |
} |
| if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
| |
if ($thesepriv{'rar'} eq 'F') { $rar=1; } |
| } |
} |
| } |
} |
| my $thesestr=''; |
my $thesestr=''; |
|
Line 5905 sub set_userprivs {
|
Line 6202 sub set_userprivs {
|
| } |
} |
| $userroles->{'user.priv.'.$role} = $thesestr; |
$userroles->{'user.priv.'.$role} = $thesestr; |
| } |
} |
| return ($author,$adv); |
return ($author,$adv,$rar); |
| } |
} |
| |
|
| sub role_status { |
sub role_status { |
|
Line 5950 sub role_status {
|
Line 6247 sub role_status {
|
| push(@rolecodes,$$role); |
push(@rolecodes,$$role); |
| &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
| } |
} |
| my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); |
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, |
| |
\%groups_roles); |
| &appenv(\%userroles,\@rolecodes); |
&appenv(\%userroles,\@rolecodes); |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); |
| } |
} |
| } |
} |
| $$tstatus = 'is'; |
$$tstatus = 'is'; |
|
Line 6071 sub set_adhoc_privileges {
|
Line 6369 sub set_adhoc_privileges {
|
| } else { |
} else { |
| &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); |
&standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); |
| } |
} |
| my ($author,$adv)= &set_userprivs(\%userroles,\%rolehash); |
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); |
| &appenv(\%userroles,[$role,'cm']); |
&appenv(\%userroles,[$role,'cm']); |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); |
| unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { |
unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { |
| &appenv( {'request.role' => $spec, |
&appenv( {'request.role' => $spec, |
| 'request.role.domain' => $dcdom, |
'request.role.domain' => $dcdom, |
|
Line 6227 sub currentdump {
|
Line 6525 sub currentdump {
|
| # |
# |
| my %returnhash=(); |
my %returnhash=(); |
| # |
# |
| if ($rep eq "unknown_cmd") { |
if ($rep eq 'unknown_cmd') { |
| # an old lond will not know currentdump |
# an old lond will not know currentdump |
| # Do a dump and make it look like a currentdump |
# Do a dump and make it look like a currentdump |
| my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
|
Line 6848 sub usertools_access {
|
Line 7146 sub usertools_access {
|
| community => 1, |
community => 1, |
| textbook => 1, |
textbook => 1, |
| placement => 1, |
placement => 1, |
| |
lti => 1, |
| ); |
); |
| } elsif ($context eq 'requestauthor') { |
} elsif ($context eq 'requestauthor') { |
| %tools = ( |
%tools = ( |
|
Line 7044 sub is_advanced_user {
|
Line 7343 sub is_advanced_user {
|
| } |
} |
| |
|
| sub check_can_request { |
sub check_can_request { |
| my ($dom,$can_request,$request_domains) = @_; |
my ($dom,$can_request,$request_domains,$uname,$udom) = @_; |
| my $canreq = 0; |
my $canreq = 0; |
| |
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { |
| |
$uname = $env{'user.name'}; |
| |
$udom = $env{'user.domain'}; |
| |
} |
| my ($types,$typename) = &Apache::loncommon::course_types(); |
my ($types,$typename) = &Apache::loncommon::course_types(); |
| my @options = ('approval','validate','autolimit'); |
my @options = ('approval','validate','autolimit'); |
| my $optregex = join('|',@options); |
my $optregex = join('|',@options); |
| if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { |
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { |
| foreach my $type (@{$types}) { |
foreach my $type (@{$types}) { |
| if (&usertools_access($env{'user.name'}, |
if (&usertools_access($uname,$udom,$type,undef, |
| $env{'user.domain'}, |
'requestcourses')) { |
| $type,undef,'requestcourses')) { |
|
| $canreq ++; |
$canreq ++; |
| if (ref($request_domains) eq 'HASH') { |
if (ref($request_domains) eq 'HASH') { |
| push(@{$request_domains->{$type}},$env{'user.domain'}); |
push(@{$request_domains->{$type}},$udom); |
| } |
} |
| if ($dom eq $env{'user.domain'}) { |
if ($dom eq $udom) { |
| $can_request->{$type} = 1; |
$can_request->{$type} = 1; |
| } |
} |
| } |
} |
| if ($env{'environment.reqcrsotherdom.'.$type} ne '') { |
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') && |
| |
($env{'environment.reqcrsotherdom.'.$type} ne '')) { |
| my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type}); |
my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type}); |
| if (@curr > 0) { |
if (@curr > 0) { |
| foreach my $item (@curr) { |
foreach my $item (@curr) { |
|
Line 7079 sub check_can_request {
|
Line 7382 sub check_can_request {
|
| } |
} |
| } |
} |
| } |
} |
| unless($dom eq $env{'user.domain'}) { |
unless ($dom eq $env{'user.domain'}) { |
| $canreq ++; |
$canreq ++; |
| if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) { |
if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) { |
| $can_request->{$type} = 1; |
$can_request->{$type} = 1; |
|
Line 7161 sub allowed {
|
Line 7464 sub allowed {
|
| |
|
| if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
| # Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
| if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) |
| || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
| && ($priv eq 'bre')) { |
&& ($priv eq 'bre')) { |
| return 'F'; |
return 'F'; |
|
Line 7209 sub allowed {
|
Line 7512 sub allowed {
|
| # Free bre to public access |
# Free bre to public access |
| |
|
| if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
| my $copyright=&metadata($uri,'copyright'); |
my $copyright; |
| |
unless ($uri =~ /ext\.tool/) { |
| |
$copyright=&metadata($uri,'copyright'); |
| |
} |
| if (($copyright eq 'public') && (!$env{'request.course.id'})) { |
if (($copyright eq 'public') && (!$env{'request.course.id'})) { |
| return 'F'; |
return 'F'; |
| } |
} |
|
Line 8170 sub fetch_enrollment_query {
|
Line 8476 sub fetch_enrollment_query {
|
| if ($xml_classlist =~ /^error/) { |
if ($xml_classlist =~ /^error/) { |
| &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); |
&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); |
| } else { |
} else { |
| if ( open(FILE,">$destname") ) { |
if ( open(FILE,">",$destname) ) { |
| print FILE &unescape($xml_classlist); |
print FILE &unescape($xml_classlist); |
| close(FILE); |
close(FILE); |
| } else { |
} else { |
|
Line 8199 sub get_query_reply {
|
Line 8505 sub get_query_reply {
|
| for (1..$loopmax) { |
for (1..$loopmax) { |
| sleep($sleep); |
sleep($sleep); |
| if (-e $replyfile.'.end') { |
if (-e $replyfile.'.end') { |
| if (open(my $fh,$replyfile)) { |
if (open(my $fh,"<",$replyfile)) { |
| $reply = join('',<$fh>); |
$reply = join('',<$fh>); |
| close($fh); |
close($fh); |
| } else { return 'error: reply_file_error'; } |
} else { return 'error: reply_file_error'; } |
|
Line 8591 sub auto_validate_class_sec {
|
Line 8897 sub auto_validate_class_sec {
|
| return $response; |
return $response; |
| } |
} |
| |
|
| |
sub auto_validate_instclasses { |
| |
my ($cdom,$cnum,$owners,$classesref) = @_; |
| |
my ($homeserver,%validations); |
| |
$homeserver = &homeserver($cnum,$cdom); |
| |
unless ($homeserver eq 'no_host') { |
| |
my $ownerlist; |
| |
if (ref($owners) eq 'ARRAY') { |
| |
$ownerlist = join(',',@{$owners}); |
| |
} else { |
| |
$ownerlist = $owners; |
| |
} |
| |
if (ref($classesref) eq 'HASH') { |
| |
my $classes = &freeze_escape($classesref); |
| |
my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist). |
| |
':'.$cdom.':'.$classes,$homeserver); |
| |
unless ($response =~ /(con_lost|error|no_such_host|refused)/) { |
| |
my @items = split(/&/,$response); |
| |
foreach my $item (@items) { |
| |
my ($key,$value) = split('=',$item); |
| |
$validations{&unescape($key)} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %validations; |
| |
} |
| |
|
| sub auto_crsreq_update { |
sub auto_crsreq_update { |
| my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, |
my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, |
| $code,$accessstart,$accessend,$inbound) = @_; |
$code,$accessstart,$accessend,$inbound) = @_; |
|
Line 8970 sub assignrole {
|
Line 9303 sub assignrole {
|
| } |
} |
| } |
} |
| } |
} |
| } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
} elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| $refused = ''; |
if ($role eq 'st') { |
| |
$refused = ''; |
| |
} elsif (($context eq 'ltienroll') && ($env{'request.lti'})) { |
| |
$refused = ''; |
| |
} |
| } elsif ($context eq 'requestcourses') { |
} elsif ($context eq 'requestcourses') { |
| my @possroles = ('st','ta','ep','in','cc','co'); |
my @possroles = ('st','ta','ep','in','cc','co'); |
| if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { |
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { |
|
Line 9086 sub assignrole {
|
Line 9423 sub assignrole {
|
| &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
| $selfenroll,$context); |
$selfenroll,$context); |
| } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || |
} elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || |
| ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh')) { |
($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') || |
| |
($role eq 'da')) { |
| &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
| $context); |
$context); |
| } elsif (($role eq 'ca') || ($role eq 'aa')) { |
} elsif (($role eq 'ca') || ($role eq 'aa')) { |
|
Line 9236 sub modifyuser {
|
Line 9574 sub modifyuser {
|
| my $newuser; |
my $newuser; |
| if ($uhome eq 'no_host') { |
if ($uhome eq 'no_host') { |
| $newuser = 1; |
$newuser = 1; |
| |
unless (($umode && ($upass ne '')) || ($umode eq 'localauth') || |
| |
($umode eq 'lti')) { |
| |
return 'error: more information needed to create new user'; |
| |
} |
| } |
} |
| # ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
| if (($uhome eq 'no_host') && |
if (($uhome eq 'no_host') && |
| (($umode && $upass) || ($umode eq 'localauth'))) { |
(($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) { |
| my $unhome=''; |
my $unhome=''; |
| if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { |
if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { |
| $unhome = $desiredhome; |
$unhome = $desiredhome; |
|
Line 9825 sub save_selected_files {
|
Line 10167 sub save_selected_files {
|
| my ($user, $path, @files) = @_; |
my ($user, $path, @files) = @_; |
| my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
| my @other_files = &files_not_in_path($user, $path); |
my @other_files = &files_not_in_path($user, $path); |
| open (OUT, '>'.$tmpdir.$filename); |
open (OUT,'>',LONCAPA::tempdir().$filename); |
| foreach my $file (@files) { |
foreach my $file (@files) { |
| print (OUT $env{'form.currentpath'}.$file."\n"); |
print (OUT $env{'form.currentpath'}.$file."\n"); |
| } |
} |
|
Line 9839 sub save_selected_files {
|
Line 10181 sub save_selected_files {
|
| sub clear_selected_files { |
sub clear_selected_files { |
| my ($user) = @_; |
my ($user) = @_; |
| my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
| open (OUT, '>'.LONCAPA::tempdir().$filename); |
open (OUT,'>',LONCAPA::tempdir().$filename); |
| print (OUT undef); |
print (OUT undef); |
| close (OUT); |
close (OUT); |
| return ("ok"); |
return ("ok"); |
|
Line 9849 sub files_in_path {
|
Line 10191 sub files_in_path {
|
| my ($user, $path) = @_; |
my ($user, $path) = @_; |
| my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
| my %return_files; |
my %return_files; |
| open (IN, '<'.LONCAPA::tempdir().$filename); |
open (IN,'<',LONCAPA::tempdir().$filename); |
| while (my $line_in = <IN>) { |
while (my $line_in = <IN>) { |
| chomp ($line_in); |
chomp ($line_in); |
| my @paths_and_file = split (m!/!, $line_in); |
my @paths_and_file = split (m!/!, $line_in); |
|
Line 9871 sub files_not_in_path {
|
Line 10213 sub files_not_in_path {
|
| my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
| my @return_files; |
my @return_files; |
| my $path_part; |
my $path_part; |
| open(IN, '<'.LONCAPA::.$filename); |
open(IN, '<',LONCAPA::tempdir().$filename); |
| while (my $line = <IN>) { |
while (my $line = <IN>) { |
| #ok, I know it's clunky, but I want it to work |
#ok, I know it's clunky, but I want it to work |
| my @paths_and_file = split(m|/|, $line); |
my @paths_and_file = split(m|/|, $line); |
|
Line 10856 sub resdata {
|
Line 11198 sub resdata {
|
| return undef; |
return undef; |
| } |
} |
| |
|
| sub get_domain_ltitools { |
sub get_domain_lti { |
| my ($cdom) = @_; |
my ($cdom,$context) = @_; |
| my %ltitools; |
my ($name,%lti); |
| my ($result,$cached)=&is_cached_new('ltitools',$cdom); |
if ($context eq 'consumer') { |
| |
$name = 'ltitools'; |
| |
} elsif ($context eq 'provider') { |
| |
$name = 'lti'; |
| |
} else { |
| |
return %lti; |
| |
} |
| |
my ($result,$cached)=&is_cached_new($name,$cdom); |
| if (defined($cached)) { |
if (defined($cached)) { |
| if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
| %ltitools = %{$result}; |
%lti = %{$result}; |
| } |
} |
| } else { |
} else { |
| my %domconfig = &get_dom('configuration',['ltitools'],$cdom); |
my %domconfig = &get_dom('configuration',[$name],$cdom); |
| if (ref($domconfig{'ltitools'}) eq 'HASH') { |
if (ref($domconfig{$name}) eq 'HASH') { |
| %ltitools = %{$domconfig{'ltitools'}}; |
%lti = %{$domconfig{$name}}; |
| |
my %encdomconfig = &get_dom('encconfig',[$name],$cdom); |
| |
if (ref($encdomconfig{$name}) eq 'HASH') { |
| |
foreach my $id (keys(%lti)) { |
| |
if (ref($encdomconfig{$name}{$id}) eq 'HASH') { |
| |
foreach my $item ('key','secret') { |
| |
$lti{$id}{$item} = $encdomconfig{$name}{$id}{$item}; |
| |
} |
| |
} |
| |
} |
| |
} |
| } |
} |
| my $cachetime = 24*60*60; |
my $cachetime = 24*60*60; |
| &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); |
&do_cache_new($name,$cdom,\%lti,$cachetime); |
| } |
} |
| return %ltitools; |
return %lti; |
| } |
} |
| |
|
| sub get_numsuppfiles { |
sub get_numsuppfiles { |
|
Line 10885 sub get_numsuppfiles {
|
Line 11244 sub get_numsuppfiles {
|
| unless (defined($cached)) { |
unless (defined($cached)) { |
| my $chome=&homeserver($cnum,$cdom); |
my $chome=&homeserver($cnum,$cdom); |
| unless ($chome eq 'no_host') { |
unless ($chome eq 'no_host') { |
| ($suppcount,my $errors) = (0,0); |
($suppcount,my $supptools,my $errors) = (0,0,0); |
| my $suppmap = 'supplemental.sequence'; |
my $suppmap = 'supplemental.sequence'; |
| ($suppcount,$errors) = |
($suppcount,$supptools,$errors) = |
| &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors); |
&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount, |
| |
$supptools,$errors); |
| } |
} |
| &do_cache_new('suppcount',$hashid,$suppcount,600); |
&do_cache_new('suppcount',$hashid,$suppcount,600); |
| } |
} |
|
Line 11178 sub EXT {
|
Line 11538 sub EXT {
|
| } else { |
} else { |
| $filename=$env{'request.filename'}; |
$filename=$env{'request.filename'}; |
| } |
} |
| my $metadata=&metadata($filename,$what); |
my $toolsymb; |
| |
if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) { |
| |
$toolsymb = $symbparm; |
| |
} |
| |
my $metadata=&metadata($filename,$what,$toolsymb); |
| if (defined($metadata)) { return &get_reply([$metadata,'resource']); } |
if (defined($metadata)) { return &get_reply([$metadata,'resource']); } |
| $metadata=&metadata($filename,'parameter_'.$what); |
$metadata=&metadata($filename,'parameter_'.$what,$toolsymb); |
| if (defined($metadata)) { return &get_reply([$metadata,'resource']); } |
if (defined($metadata)) { return &get_reply([$metadata,'resource']); } |
| |
|
| # ----------------------------------------------- fifth, look in rest of course |
# ----------------------------------------------- fifth, look in rest of course |
|
Line 11206 sub EXT {
|
Line 11570 sub EXT {
|
| if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } |
if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } |
| } |
} |
| if ($recurse) { return undef; } |
if ($recurse) { return undef; } |
| my $pack_def=&packages_tab_default($filename,$varname); |
my $pack_def=&packages_tab_default($filename,$varname,$toolsymb); |
| if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } |
if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } |
| # ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
| } elsif ($realm eq 'environment') { |
} elsif ($realm eq 'environment') { |
|
Line 11300 sub sort_course_groups { # Sort groups b
|
Line 11664 sub sort_course_groups { # Sort groups b
|
| } |
} |
| |
|
| sub packages_tab_default { |
sub packages_tab_default { |
| my ($uri,$varname)=@_; |
my ($uri,$varname,$toolsymb)=@_; |
| my (undef,$part,$name)=split(/\./,$varname); |
my (undef,$part,$name)=split(/\./,$varname); |
| |
|
| my (@extension,@specifics,$do_default); |
my (@extension,@specifics,$do_default); |
| foreach my $package (split(/,/,&metadata($uri,'packages'))) { |
foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) { |
| my ($pack_type,$pack_part)=split(/_/,$package,2); |
my ($pack_type,$pack_part)=split(/_/,$package,2); |
| if ($pack_type eq 'default') { |
if ($pack_type eq 'default') { |
| $do_default=1; |
$do_default=1; |
|
Line 11371 sub add_prefix_and_part {
|
Line 11735 sub add_prefix_and_part {
|
| |
|
| my %metaentry; |
my %metaentry; |
| my %importedpartids; |
my %importedpartids; |
| |
my %importedrespids; |
| sub metadata { |
sub metadata { |
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| # if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
| if (($uri eq '') || |
if (($uri eq '') || |
| (($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
| ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|exttools?)$})) || |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || |
| ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
| return undef; |
return undef; |
| } |
} |
|
Line 11396 sub metadata {
|
Line 11761 sub metadata {
|
| my ($result,$cached)=&is_cached_new('meta',$uri); |
my ($result,$cached)=&is_cached_new('meta',$uri); |
| if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
| } |
} |
| |
|
| |
# |
| |
# If the uri is for an external tool the file from |
| |
# which metadata should be retrieved depends on whether |
| |
# the tool had been configured to be gradable (set in the Course |
| |
# Editor or Resource Editor). |
| |
# |
| |
# If a valid symb has been included as the third arg in the call |
| |
# to &metadata() that can be used to retrieve the value of |
| |
# parameter_0_gradable set for the resource, and included in the |
| |
# uploaded map containing the tool. The value is retrieved via |
| |
# &EXT(), if a valid symb is available. Otherwise the value of |
| |
# gradable in the exttool_$marker.db file for the tool instance |
| |
# is retrieved via &get(). |
| |
# |
| |
# When lonuserstate::traceroute() calls lonnet::EXT() for |
| |
# hiddenresource and encrypturl (during course initialization) |
| |
# 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 |
| |
# this case fall back to retrieving gradable status from the |
| |
# exttool_$marker.db file. |
| |
# |
| |
# In order to avoid an infinite loop, &metadata() will return |
| |
# before a call to &EXT(), if the uri is for an external tool |
| |
# and the $what for which metadata is being requested is |
| |
# parameter_0_gradable or 0_gradable. |
| |
# |
| |
|
| |
if ($uri =~ /ext\.tool$/) { |
| |
if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) { |
| |
return; |
| |
} else { |
| |
my ($checked,$use_passback); |
| |
if ($toolsymb ne '') { |
| |
(undef,undef,my $tooluri) = &decode_symb($toolsymb); |
| |
if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) { |
| |
$checked = 1; |
| |
if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) { |
| |
$use_passback = 1; |
| |
} |
| |
} |
| |
} |
| |
unless ($checked) { |
| |
my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri); |
| |
$marker=~s/\D//g; |
| |
if ($marker) { |
| |
my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum); |
| |
$use_passback = $toolsettings{'gradable'}; |
| |
} |
| |
} |
| |
if ($use_passback) { |
| |
$filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool'; |
| |
} else { |
| |
$filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool'; |
| |
} |
| |
} |
| |
} |
| |
|
| { |
{ |
| # Imported parts would go here |
# Imported parts would go here |
| my %importedids=(); |
my @origfiletagids=(); |
| my @origfileimportpartids=(); |
|
| my $importedparts=0; |
my $importedparts=0; |
| |
|
| |
# Imported responseids would go here |
| |
my $importedresponses=0; |
| # |
# |
| # Is this a recursive call for a library? |
# Is this a recursive call for a library? |
| # |
# |
|
Line 11495 sub metadata {
|
Line 11921 sub metadata {
|
| my $dir=$filename; |
my $dir=$filename; |
| $dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
| $location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
| |
|
| |
my $importid=$token->[2]->{'id'}; |
| my $importmode=$token->[2]->{'importmode'}; |
my $importmode=$token->[2]->{'importmode'}; |
| |
# |
| |
# Check metadata for imported file to |
| |
# see if it contained response items |
| |
# |
| |
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; |
| |
# 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); |
| |
} |
| |
} |
| |
} |
| |
# Do not overwrite contents of %metaentry hash for resource itself with |
| |
# hash populated for imported library file |
| |
%metaentry = %currmetaentry; |
| |
undef(%currmetaentry); |
| if ($importmode eq 'problem') { |
if ($importmode eq 'problem') { |
| # Import as problem/response |
# Import as problem/response |
| $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
Line 11505 sub metadata {
|
Line 11960 sub metadata {
|
| $importedparts=1; |
$importedparts=1; |
| # We need to get the original file and the imported file to get the part order correct |
# We need to get the original file and the imported file to get the part order correct |
| # Good news: we do not need to worry about nested libraries, since parts cannot be nested |
# Good news: we do not need to worry about nested libraries, since parts cannot be nested |
| # Load and inspect original file |
# Load and inspect original file if we didn't do that already |
| if ($#origfileimportpartids<0) { |
if ($#origfiletagids<0) { |
| undef(%importedpartids); |
undef(%importedrespids); |
| my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
undef(%importedpartids); |
| my $origfile=&getfile($origfilelocation); |
if ($origfile eq '') { |
| @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
| |
$origfile=&getfile($origfilelocation); |
| |
@origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
| |
} |
| } |
} |
| |
|
| # Load and inspect imported file |
# Load and inspect imported file |
|
Line 11535 sub metadata {
|
Line 11993 sub metadata {
|
| |
|
| if ($depthcount<20) { |
if ($depthcount<20) { |
| my $metadata = |
my $metadata = |
| &metadata($uri,'keys', $location,$unikey, |
&metadata($uri,'keys',$toolsymb,$location,$unikey, |
| $depthcount+1); |
$depthcount+1); |
| foreach my $meta (split(',',$metadata)) { |
foreach my $meta (split(',',$metadata)) { |
| $metaentry{':'.$meta}=$metaentry{':'.$meta}; |
$metaentry{':'.$meta}=$metaentry{':'.$meta}; |
| $metathesekeys{$meta}=1; |
$metathesekeys{$meta}=1; |
| } |
} |
| |
|
| } |
} |
| } else { |
} else { |
| # |
# |
|
Line 11610 sub metadata {
|
Line 12067 sub metadata {
|
| $dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
| $location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
| my $rights_metadata = |
my $rights_metadata = |
| &metadata($uri,'keys',$location,'_rights', |
&metadata($uri,'keys',$toolsymb,$location,'_rights', |
| $depthcount+1); |
$depthcount+1); |
| foreach my $rights (split(',',$rights_metadata)) { |
foreach my $rights (split(',',$rights_metadata)) { |
| #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; |
#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; |
|
Line 11624 sub metadata {
|
Line 12081 sub metadata {
|
| grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
| $metaentry{':packages'} = join(',',@uniq_packages); |
$metaentry{':packages'} = join(',',@uniq_packages); |
| |
|
| if ($importedparts) { |
if (($importedresponses) || ($importedparts)) { |
| |
if ($importedparts) { |
| # We had imported parts and need to rebuild partorder |
# We had imported parts and need to rebuild partorder |
| $metaentry{':partorder'}=''; |
$metaentry{':partorder'}=''; |
| $metathesekeys{'partorder'}=1; |
$metathesekeys{'partorder'}=1; |
| for (my $index=0;$index<$#origfileimportpartids;$index+=2) { |
} |
| if ($origfileimportpartids[$index] eq 'part') { |
if ($importedresponses) { |
| # original part, part of the problem |
# We had imported responses and need to rebuil responseorder |
| $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; |
$metaentry{':responseorder'}=''; |
| } else { |
$metathesekeys{'responseorder'}=1; |
| # we have imported parts at this position |
} |
| $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; |
for (my $index=0;$index<$#origfiletagids;$index+=2) { |
| } |
my $origid = $origfiletagids[$index+1]; |
| } |
if ($origfiletagids[$index] eq 'part') { |
| $metaentry{':partorder'}=~s/^\,//; |
# Original part, part of the problem |
| |
if ($importedparts) { |
| |
$metaentry{':partorder'}.=','.$origid; |
| |
} |
| |
} elsif ($origfiletagids[$index] eq 'import') { |
| |
if ($importedparts) { |
| |
# We have imported parts at this position |
| |
$metaentry{':partorder'}.=','.$importedpartids{$origid}; |
| |
} |
| |
if ($importedresponses) { |
| |
# We have imported responses at this position |
| |
if (ref($importedrespids{$origid}) eq 'ARRAY') { |
| |
$metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}}); |
| |
} |
| |
} |
| |
} else { |
| |
# Original response item, part of the problem |
| |
if ($importedresponses) { |
| |
$metaentry{':responseorder'}.=','.$origid; |
| |
} |
| |
} |
| |
} |
| |
if ($importedparts) { |
| |
$metaentry{':partorder'}=~s/^\,//; |
| |
} |
| |
if ($importedresponses) { |
| |
$metaentry{':responseorder'}=~s/^\,//; |
| |
} |
| } |
} |
| |
|
| $metaentry{':keys'} = join(',',keys(%metathesekeys)); |
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
|
Line 12653 sub repcopy_userfile {
|
Line 13138 sub repcopy_userfile {
|
| } |
} |
| # now the path exists for sure |
# now the path exists for sure |
| # get a user agent |
# get a user agent |
| my $ua=new LWP::UserAgent; |
|
| my $transferfile=$file.'.in.transfer'; |
my $transferfile=$file.'.in.transfer'; |
| # FIXME: this should flock |
# FIXME: this should flock |
| if (-e $transferfile) { return 'ok'; } |
if (-e $transferfile) { return 'ok'; } |
|
Line 12663 sub repcopy_userfile {
|
Line 13147 sub repcopy_userfile {
|
| my $protocol = $protocol{$homeserver}; |
my $protocol = $protocol{$homeserver}; |
| $protocol = 'http' if ($protocol ne 'https'); |
$protocol = 'http' if ($protocol ne 'https'); |
| $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); |
$request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); |
| my $response=$ua->request($request,$transferfile); |
my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1); |
| # did it work? |
# did it work? |
| if ($response->is_error()) { |
if ($response->is_error()) { |
| unlink($transferfile); |
unlink($transferfile); |
|
Line 12707 sub getuploaded {
|
Line 13191 sub getuploaded {
|
| my $protocol = $protocol{$homeserver}; |
my $protocol = $protocol{$homeserver}; |
| $protocol = 'http' if ($protocol ne 'https'); |
$protocol = 'http' if ($protocol ne 'https'); |
| $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; |
$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; |
| my $ua=new LWP::UserAgent; |
|
| my $request=new HTTP::Request($reqtype,$uri); |
my $request=new HTTP::Request($reqtype,$uri); |
| my $response=$ua->request($request); |
my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1); |
| $$rtncode = $response->code; |
$$rtncode = $response->code; |
| if (! $response->is_success()) { |
if (! $response->is_success()) { |
| return 'failed'; |
return 'failed'; |
|
Line 12726 sub readfile {
|
Line 13209 sub readfile {
|
| my $file = shift; |
my $file = shift; |
| if ( (! -e $file ) || ($file eq '') ) { return -1; }; |
if ( (! -e $file ) || ($file eq '') ) { return -1; }; |
| my $fh; |
my $fh; |
| open($fh,"<$file"); |
open($fh,"<",$file); |
| my $a=''; |
my $a=''; |
| while (my $line = <$fh>) { $a .= $line; } |
while (my $line = <$fh>) { $a .= $line; } |
| return $a; |
return $a; |
|
Line 12839 sub machine_ids {
|
Line 13322 sub machine_ids {
|
| |
|
| sub additional_machine_domains { |
sub additional_machine_domains { |
| my @domains; |
my @domains; |
| open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); |
open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab"); |
| while( my $line = <$fh>) { |
while( my $line = <$fh>) { |
| $line =~ s/\s//g; |
$line =~ s/\s//g; |
| push(@domains,$line); |
push(@domains,$line); |
|
Line 12910 sub clutter {
|
Line 13393 sub clutter {
|
| # &logthis("Got a blank emb style"); |
# &logthis("Got a blank emb style"); |
| } |
} |
| } |
} |
| } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) { |
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { |
| $thisfn='/adm/wrapper'.$thisfn; |
$thisfn='/adm/wrapper'.$thisfn; |
| } |
} |
| return $thisfn; |
return $thisfn; |
|
Line 12985 sub get_dns {
|
Line 13468 sub get_dns {
|
| } |
} |
| |
|
| my %alldns; |
my %alldns; |
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); |
| foreach my $dns (<$config>) { |
foreach my $dns (<$config>) { |
| next if ($dns !~ /^\^(\S*)/x); |
next if ($dns !~ /^\^(\S*)/x); |
| my $line = $1; |
my $line = $1; |
|
Line 12997 sub get_dns {
|
Line 13480 sub get_dns {
|
| } |
} |
| while (%alldns) { |
while (%alldns) { |
| my ($dns) = sort { $b cmp $a } keys(%alldns); |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
| my $ua=new LWP::UserAgent; |
|
| $ua->timeout(30); |
|
| my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
| my $response=$ua->request($request); |
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); |
| delete($alldns{$dns}); |
delete($alldns{$dns}); |
| next if ($response->is_error()); |
next if ($response->is_error()); |
| my @content = split("\n",$response->content); |
my @content = split("\n",$response->content); |
|
Line 13013 sub get_dns {
|
Line 13494 sub get_dns {
|
| close($config); |
close($config); |
| my $which = (split('/',$url))[3]; |
my $which = (split('/',$url))[3]; |
| &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
| open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); |
open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab"); |
| my @content = <$config>; |
my @content = <$config>; |
| &$func(\@content,$hashref); |
&$func(\@content,$hashref); |
| return; |
return; |
|
Line 13106 sub fetch_dns_checksums {
|
Line 13587 sub fetch_dns_checksums {
|
| my ($ignore_cache,$nocache) = @_; |
my ($ignore_cache,$nocache) = @_; |
| &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); |
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); |
| my $fh; |
my $fh; |
| if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) { |
| my @lines = <$fh>; |
my @lines = <$fh>; |
| &parse_domain_tab(\@lines); |
&parse_domain_tab(\@lines); |
| } |
} |
|
Line 13158 sub fetch_dns_checksums {
|
Line 13639 sub fetch_dns_checksums {
|
| my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
| $name=~s/\s//g; |
$name=~s/\s//g; |
| if ($id && $domain && $role && $name) { |
if ($id && $domain && $role && $name) { |
| |
if ((exists($hostname{$id})) && ($hostname{$id} ne '')) { |
| |
my $curr = $hostname{$id}; |
| |
my $skip; |
| |
if (ref($name_to_host{$curr}) eq 'ARRAY') { |
| |
if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) { |
| |
$skip = 1; |
| |
} else { |
| |
@{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}}; |
| |
} |
| |
} |
| |
unless ($skip) { |
| |
push(@{$name_to_host{$name}},$id); |
| |
} |
| |
} else { |
| |
push(@{$name_to_host{$name}},$id); |
| |
} |
| $hostname{$id}=$name; |
$hostname{$id}=$name; |
| push(@{$name_to_host{$name}}, $id); |
|
| $hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
| if (defined($protocol)) { |
if (defined($protocol)) { |
|
Line 13182 sub fetch_dns_checksums {
|
Line 13678 sub fetch_dns_checksums {
|
| &purge_remembered(); |
&purge_remembered(); |
| &reset_domain_info(); |
&reset_domain_info(); |
| &reset_hosts_ip_info(); |
&reset_hosts_ip_info(); |
| |
undef(%internetdom); |
| undef(%name_to_host); |
undef(%name_to_host); |
| undef(%hostname); |
undef(%hostname); |
| undef(%hostdom); |
undef(%hostdom); |
|
Line 13192 sub fetch_dns_checksums {
|
Line 13689 sub fetch_dns_checksums {
|
| sub load_hosts_tab { |
sub load_hosts_tab { |
| my ($ignore_cache,$nocache) = @_; |
my ($ignore_cache,$nocache) = @_; |
| &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); |
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); |
| my @config = <$config>; |
my @config = <$config>; |
| &parse_hosts_tab(\@config); |
&parse_hosts_tab(\@config); |
| close($config); |
close($config); |
|
Line 13224 sub fetch_dns_checksums {
|
Line 13721 sub fetch_dns_checksums {
|
| return %hostdom; |
return %hostdom; |
| } |
} |
| |
|
| |
sub all_host_intdom { |
| |
&load_hosts_tab() if (!$loaded); |
| |
return %internetdom; |
| |
} |
| |
|
| sub is_library { |
sub is_library { |
| &load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
| |
|
|
Line 13458 sub all_loncaparevs {
|
Line 13960 sub all_loncaparevs {
|
| { |
{ |
| sub load_loncaparevs { |
sub load_loncaparevs { |
| if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { |
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { |
| if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { |
if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) { |
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
| my ($hostid,$loncaparev)=split(/:/,$configline); |
my ($hostid,$loncaparev)=split(/:/,$configline); |
|
Line 13474 sub all_loncaparevs {
|
Line 13976 sub all_loncaparevs {
|
| { |
{ |
| sub load_serverhomeIDs { |
sub load_serverhomeIDs { |
| if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { |
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { |
| if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { |
if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { |
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
| my ($name,$id)=split(/:/,$configline); |
my ($name,$id)=split(/:/,$configline); |
|
Line 13499 BEGIN {
|
Line 14001 BEGIN {
|
| |
|
| # ------------------------------------------------------ Read spare server file |
# ------------------------------------------------------ Read spare server file |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
|
Line 13513 BEGIN {
|
Line 14015 BEGIN {
|
| } |
} |
| # ------------------------------------------------------------ Read permissions |
# ------------------------------------------------------------ Read permissions |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
|
Line 13527 BEGIN {
|
Line 14029 BEGIN {
|
| |
|
| # -------------------------------------------- Read plain texts for permissions |
# -------------------------------------------- Read plain texts for permissions |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
|
Line 13547 BEGIN {
|
Line 14049 BEGIN {
|
| |
|
| # ---------------------------------------------------------- Read package table |
# ---------------------------------------------------------- Read package table |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| if ($configline !~ /\S/ || $configline=~/^#/) { next; } |
if ($configline !~ /\S/ || $configline=~/^#/) { next; } |
|
Line 13601 BEGIN {
|
Line 14103 BEGIN {
|
| # ---------------------------------------------------------- Read managers table |
# ---------------------------------------------------------- Read managers table |
| { |
{ |
| if (-e "$perlvar{'lonTabDir'}/managers.tab") { |
if (-e "$perlvar{'lonTabDir'}/managers.tab") { |
| if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { |
if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) { |
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
| next if ($configline =~ /^\#/); |
next if ($configline =~ /^\#/); |
|
Line 14340 condval($condidx) : value of condition i
|
Line 14842 condval($condidx) : value of condition i
|
| |
|
| =item * |
=item * |
| |
|
| metadata($uri,$what,$liburi,$prefix,$depthcount) : request a |
metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a |
| resource's metadata, $what should be either a specific key, or either |
resource's metadata, $what should be either a specific key, or either |
| 'keys' (to get a list of possible keys) or 'packages' to get a list of |
'keys' (to get a list of possible keys) or 'packages' to get a list of |
| packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. |
packages that this resource currently uses, the last 3 arguments are |
| |
only used internally for recursive metadata. |
| |
|
| |
the toolsymb is only used where the uri is for an external tool (for which |
| |
the uri as well as the symb are guaranteed to be unique). |
| |
|
| this function automatically caches all requests |
this function automatically caches all requests |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl