|
version 1.1356, 2017/10/07 00:50:52
|
version 1.1366, 2018/01/03 04:21:02
|
|
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 707 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 2094 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 2135 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 3597 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 3655 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 3806 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 3881 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 3939 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 4899 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 5209 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 7484 sub allowed {
|
Line 7507 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 8445 sub fetch_enrollment_query {
|
Line 8471 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 8474 sub get_query_reply {
|
Line 8500 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 10101 sub save_selected_files {
|
Line 10127 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 10115 sub save_selected_files {
|
Line 10141 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 10125 sub files_in_path {
|
Line 10151 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 10147 sub files_not_in_path {
|
Line 10173 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 11132 sub resdata {
|
Line 11158 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 11171 sub get_numsuppfiles {
|
Line 11204 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 11464 sub EXT {
|
Line 11498 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 11492 sub EXT {
|
Line 11530 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 11586 sub sort_course_groups { # Sort groups b
|
Line 11624 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 11658 sub add_prefix_and_part {
|
Line 11696 sub add_prefix_and_part {
|
| my %metaentry; |
my %metaentry; |
| my %importedpartids; |
my %importedpartids; |
| 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 11682 sub metadata {
|
Line 11720 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 %importedids=(); |
|
Line 11821 sub metadata {
|
Line 11918 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}; |
|
Line 11896 sub metadata {
|
Line 11993 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 13010 sub readfile {
|
Line 13107 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 13123 sub machine_ids {
|
Line 13220 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 13269 sub get_dns {
|
Line 13366 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 13295 sub get_dns {
|
Line 13392 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 13388 sub fetch_dns_checksums {
|
Line 13485 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 13490 sub fetch_dns_checksums {
|
Line 13587 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 13761 sub all_loncaparevs {
|
Line 13858 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 13777 sub all_loncaparevs {
|
Line 13874 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 13802 BEGIN {
|
Line 13899 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 13816 BEGIN {
|
Line 13913 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 13830 BEGIN {
|
Line 13927 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 13850 BEGIN {
|
Line 13947 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 13904 BEGIN {
|
Line 14001 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 14643 condval($condidx) : value of condition i
|
Line 14740 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