|
version 1.1348, 2017/08/08 15:33:13
|
version 1.1372, 2018/03/30 23:50:29
|
|
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 485 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 525 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 534 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 650 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); |
my ($linkname,$pubname); |
| if ($name eq '') { |
if ($name eq '') { |
|
Line 678 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 698 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 1600 sub internet_dom_servers {
|
Line 1610 sub internet_dom_servers {
|
| |
|
| sub trusted_domains { |
sub trusted_domains { |
| my ($cmdtype,$calldom) = @_; |
my ($cmdtype,$calldom) = @_; |
| my (%trusted,%untrusted); |
my ($trusted,$untrusted); |
| if (&domain($calldom) eq '') { |
if (&domain($calldom) eq '') { |
| return (\%trusted,\%untrusted); |
return ($trusted,$untrusted); |
| } |
} |
| unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) { |
unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) { |
| return (\%trusted,\%untrusted); |
return ($trusted,$untrusted); |
| } |
} |
| my $callprimary = &domain($calldom,'primary'); |
my $callprimary = &domain($calldom,'primary'); |
| my $intcalldom = &Apache::lonnet::internet_dom($callprimary); |
my $intcalldom = &Apache::lonnet::internet_dom($callprimary); |
| if ($intcalldom eq '') { |
if ($intcalldom eq '') { |
| return (\%trusted,\%untrusted); |
return ($trusted,$untrusted); |
| } |
} |
| |
|
| my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom); |
my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom); |
|
Line 1660 sub trusted_domains {
|
Line 1670 sub trusted_domains {
|
| } |
} |
| foreach my $exc (@allexc) { |
foreach my $exc (@allexc) { |
| if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { |
if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { |
| map { $untrusted{$_}; } @{$doms_by_intdom{$exc}}; |
$untrusted = $doms_by_intdom{$exc}; |
| } |
} |
| } |
} |
| foreach my $inc (@allinc) { |
foreach my $inc (@allinc) { |
| if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { |
if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { |
| map { $trusted{$_}; } @{$doms_by_intdom{$inc}}; |
$trusted = $doms_by_intdom{$inc}; |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| return(\%trusted,\%untrusted); |
return ($trusted,$untrusted); |
| } |
} |
| |
|
| sub will_trust { |
sub will_trust { |
|
Line 2085 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'}).':'. |
|
Line 2126 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 2444 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 3171 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 3520 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 3578 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 3694 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 3729 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 3804 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 3862 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 4822 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 5132 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 7046 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 7242 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 7277 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 7407 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 8368 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 8397 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 8789 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 9168 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 9435 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 10024 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 10038 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 10048 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 10070 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 11055 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',['ltitools'],$cdom); |
my %encdomconfig = &get_dom('encconfig',[$name],$cdom); |
| if (ref($encdomconfig{'ltitools'}) eq 'HASH') { |
if (ref($encdomconfig{$name}) eq 'HASH') { |
| foreach my $id (keys(%ltitools)) { |
foreach my $id (keys(%lti)) { |
| if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') { |
if (ref($encdomconfig{$name}{$id}) eq 'HASH') { |
| foreach my $item ('key','secret') { |
foreach my $item ('key','secret') { |
| $ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item}; |
$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 11094 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 11387 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 11415 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 11509 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 11580 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 '') || |
|
Line 11605 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 11704 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 ($origfile,@libfilekeys); |
| |
my %currmetaentry = %metaentry; |
| |
@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); |
| |
} |
| |
@{$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 11714 sub metadata {
|
Line 11965 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); |
| |
} |
| |
} |
| |
my @impfilepartids; |
| |
# If <partorder> tag is included in metadata for the imported file |
| |
# get the parts in the imported file from that. |
| |
if (grep(/^partorder$/,@libfilekeys)) { |
| |
%currmetaentry = %metaentry; |
| |
my $libpartorder = &metadata($location,'partorder',undef,undef,undef, |
| |
$depthcount+1); |
| |
%metaentry = %currmetaentry; |
| |
undef(%currmetaentry); |
| |
if ($libpartorder ne '') { |
| |
@impfilepartids=split(/\s*,\s*/,$libpartorder); |
| |
} |
| |
} else { |
| |
# If no <partorder> tag available, load and inspect imported file |
| |
my $impfile=&getfile($location); |
| |
@impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
| } |
} |
| |
|
| # Load and inspect imported file |
|
| my $impfile=&getfile($location); |
|
| my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
| if ($#impfilepartids>=0) { |
if ($#impfilepartids>=0) { |
| # This problem had parts |
# This problem had parts |
| $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); |
$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); |
|
Line 11744 sub metadata {
|
Line 12011 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 11819 sub metadata {
|
Line 12085 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 11833 sub metadata {
|
Line 12099 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)); |
| &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
| $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys)); |
$metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys)); |
| &do_cache_new('meta',$uri,\%metaentry,$cachetime); |
unless ($liburi) { |
| |
&do_cache_new('meta',$uri,\%metaentry,$cachetime); |
| |
} |
| # this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
| } |
} |
| return $metaentry{':'.$what}; |
return $metaentry{':'.$what}; |
|
Line 12933 sub readfile {
|
Line 13228 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 13046 sub machine_ids {
|
Line 13341 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 13192 sub get_dns {
|
Line 13487 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 13218 sub get_dns {
|
Line 13513 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 13311 sub fetch_dns_checksums {
|
Line 13606 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 13363 sub fetch_dns_checksums {
|
Line 13658 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 13398 sub fetch_dns_checksums {
|
Line 13708 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 13669 sub all_loncaparevs {
|
Line 13979 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 13685 sub all_loncaparevs {
|
Line 13995 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 13710 BEGIN {
|
Line 14020 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 13724 BEGIN {
|
Line 14034 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 13738 BEGIN {
|
Line 14048 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 13758 BEGIN {
|
Line 14068 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 13812 BEGIN {
|
Line 14122 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 14551 condval($condidx) : value of condition i
|
Line 14861 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 except any made recursively |
| |
to retrieve a list of metadata keys for an imported library file ($liburi is |
| |
defined). |
| |
|
| =item * |
=item * |
| |
|
![[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