--- loncom/lonnet/perl/lonnet.pm 2020/07/17 23:36:00 1.1172.2.93.4.13
+++ loncom/lonnet/perl/lonnet.pm 2019/02/15 21:34:43 1.1172.2.104
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.93.4.13 2020/07/17 23:36:00 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.104 2019/02/15 21:34:43 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -75,7 +75,7 @@ use LWP::UserAgent();
use HTTP::Date;
use Image::Magick;
-use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
+use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
%managerstab);
@@ -1700,12 +1700,7 @@ sub get_dom {
}
}
if ($udom && $uhome && ($uhome ne 'no_host')) {
- my $rep;
- if ($namespace =~ /^enc/) {
- $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
- } else {
- $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
- }
+ my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
my %returnhash;
if ($rep eq '' || $rep =~ /^error: 2 /) {
return %returnhash;
@@ -1749,11 +1744,7 @@ sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
- if ($namespace =~ /^enc/) {
- return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
- } else {
- return &reply("putdom:$udom:$namespace:$items",$uhome);
- }
+ return &reply("putdom:$udom:$namespace:$items",$uhome);
} else {
&logthis("put_dom failed - no homeserver and/or domain");
}
@@ -1844,17 +1835,6 @@ sub inst_directory_query {
my $homeserver = &domain($udom,'primary');
my $outcome;
if ($homeserver ne '') {
- unless ($homeserver eq $perlvar{'lonHostID'}) {
- if ($srch->{'srchby'} eq 'email') {
- my $lcrev = &get_server_loncaparev(undef,$homeserver);
- my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.([\w.\-]+)\'?$/);
- if (($major eq '' && $minor eq '') || ($major < 2) ||
- (($major == 2) && ($minor < 11)) ||
- (($major == 2) && ($minor == 11) && ($subver !~ /^2\.B/))) {
- return;
- }
- }
- }
my $queryid=&reply("querysend:instdirsearch:".
&escape($srch->{'srchby'}).':'.
&escape($srch->{'srchterm'}).':'.
@@ -1896,15 +1876,6 @@ sub usersearch {
my $query = 'usersearch';
foreach my $tryserver (keys(%libserv)) {
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,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.([\w.\-]+)\'?$/);
- next if (($major eq '' && $minor eq '') || ($major < 2) ||
- (($major == 2) && ($minor < 11)) ||
- (($major == 2) && ($minor == 11) && ($subver !~ /^2\.B/)));
- }
- }
my $host=&hostname($tryserver);
my $queryid=
&reply("querysend:".&escape($query).':'.
@@ -2222,6 +2193,9 @@ sub get_domain_defaults {
} elsif ($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'}{'remote'}) eq 'HASH') {
@@ -2285,22 +2259,6 @@ sub get_domain_defaults {
return %domdefaults;
}
-sub course_portal_url {
- my ($cnum,$cdom) = @_;
- my $chome = &homeserver($cnum,$cdom);
- my $hostname = &hostname($chome);
- my $protocol = $protocol{$chome};
- $protocol = 'http' if ($protocol ne 'https');
- my %domdefaults = &get_domain_defaults($cdom);
- my $firsturl;
- if ($domdefaults{'portal_def'}) {
- $firsturl = $domdefaults{'portal_def'};
- } else {
- $firsturl = $protocol.'://'.$hostname;
- }
- return $firsturl;
-}
-
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -2885,8 +2843,7 @@ sub absolute_url {
sub ssi {
my ($fn,%form)=@_;
- my $ua=new LWP::UserAgent;
- my $request;
+ my ($request,$response);
$form{'no_update_last_known'}=1;
&Apache::lonenc::check_encrypt(\$fn);
@@ -2903,7 +2860,30 @@ sub ssi {
}
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
- my $response= $ua->request($request);
+
+ if (($env{'request.course.id'}) &&
+ ($form{'grade_courseid'} eq $env{'request.course.id'}) &&
+ ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
+ ($form{'grade_symb'} ne '') &&
+ (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.
+ ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
+ if (LWP::UserAgent->VERSION >= 5.834) {
+ my $ua=new LWP::UserAgent;
+ $ua->local_address('127.0.0.1');
+ $response = $ua->request($request);
+ } else {
+ {
+ require LWP::Protocol::http;
+ local @LWP::Protocol::http::EXTRA_SOCK_OPTS = (LocalAddr => '127.0.0.1');
+ my $ua=new LWP::UserAgent;
+ $response = $ua->request($request);
+ @LWP::Protocol::http::EXTRA_SOCK_OPTS = ();
+ }
+ }
+ } else {
+ my $ua=new LWP::UserAgent;
+ $response = $ua->request($request);
+ }
if (wantarray) {
return ($response->content, $response);
} else {
@@ -2923,6 +2903,72 @@ 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 $ua=new LWP::UserAgent;
+ $ua->timeout(5);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ my $hostname = &hostname($homeserver);
+ if ($hostname) {
+ my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
+ my $request=new HTTP::Request('HEAD',$uri);
+ my $response=$ua->request($request);
+ 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
sub allowuploaded {
@@ -3061,14 +3107,6 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
- } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
- $incourse = 1;
- if ($env{'form.forceedit'}) {
- $forceview = 1;
- } else {
- $forceedit = 1;
- }
- $cfile = $resurl;
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
@@ -3093,14 +3131,6 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
- } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
- $incourse = 1;
- if ($env{'form.forceedit'}) {
- $forceview = 1;
- } else {
- $forceedit = 1;
- }
- $cfile = $resurl;
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
$incourse = 1;
$forceview = 1;
@@ -3110,13 +3140,8 @@ sub can_edit_resource {
$cfile = &clutter($res);
} else {
$cfile = $env{'form.suppurl'};
- my $escfile = &unescape($cfile);
- if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
- $cfile = '/adm/wrapper'.$escfile;
- } else {
- $escfile =~ s{^http://}{};
- $cfile = &escape("/adm/wrapper/ext/$escfile");
- }
+ $cfile =~ s{^http://}{};
+ $cfile = '/adm/wrapper/ext/'.$cfile;
}
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
if ($env{'form.forceedit'}) {
@@ -3404,16 +3429,13 @@ sub resizeImage {
# input: $formname - the contents of the file are in $env{"form.$formname"}
# the desired filename is in $env{"form.$formname.filename"}
# $context - possible values: coursedoc, existingfile, overwrite,
-# canceloverwrite, scantron or ''.
+# canceloverwrite, or ''.
# if 'coursedoc': upload to the current course
# if 'existingfile': write file to tmp/overwrites directory
# if 'canceloverwrite': delete file written to tmp/overwrites directory
# $context is passed as argument to &finishuserfileupload
# $subdir - directory in userfile to store the file into
-# $parser - instruction to parse file for objects ($parser = parse) or
-# if context is 'scantron', $parser is hashref of csv column mapping
-# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,
-# Section => 4, CODE => 5, FirstQuestion => 9 }).
+# $parser - instruction to parse file for objects ($parser = parse)
# $allfiles - reference to hash for embedded objects
# $codebase - reference to hash for codebase of java objects
# $desuname - username for permanent storage of uploaded file
@@ -3454,7 +3476,7 @@ sub userfileupload {
} else {
$docudom = $env{'user.domain'};
}
- if ($destuname =~ /^$match_username$/) {
+ if ($destuname =~ /^$match_username$/) {
$docuname = $destuname;
} else {
$docuname = $env{'user.name'};
@@ -3603,7 +3625,7 @@ sub finishuserfileupload {
}
}
}
- if (($context ne 'scantron') && ($parser eq 'parse')) {
+ if ($parser eq 'parse') {
if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,
$allfiles,$codebase);
@@ -3612,9 +3634,6 @@ sub finishuserfileupload {
' for embedded media: '.$parse_result);
}
}
- } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) {
- my $format = $env{'form.scantron_format'};
- &bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format);
}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
my $input = $filepath.'/'.$file;
@@ -3855,246 +3874,6 @@ sub embedded_dependency {
return;
}
-sub bubblesheet_converter {
- my ($cdom,$fullpath,$config,$format) = @_;
- if ((&domain($cdom) ne '') &&
- ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
- (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
- my (%csvcols,%csvoptions);
- if (ref($config->{'fields'}) eq 'HASH') {
- %csvcols = %{$config->{'fields'}};
- }
- if (ref($config->{'options'}) eq 'HASH') {
- %csvoptions = %{$config->{'options'}};
- }
- my %csvbynum = reverse(%csvcols);
- my %scantronconf = &get_scantron_config($format,$cdom);
- if (keys(%scantronconf)) {
- my %bynum = (
- $scantronconf{CODEstart} => 'CODEstart',
- $scantronconf{IDstart} => 'IDstart',
- $scantronconf{PaperID} => 'PaperID',
- $scantronconf{FirstName} => 'FirstName',
- $scantronconf{LastName} => 'LastName',
- $scantronconf{Qstart} => 'Qstart',
- );
- my @ordered;
- foreach my $item (sort { $a <=> $b } keys(%bynum)) {
- push(@ordered,$bynum{$item});
- }
- my %mapstart = (
- CODEstart => 'CODE',
- IDstart => 'ID',
- PaperID => 'PaperID',
- FirstName => 'FirstName',
- LastName => 'LastName',
- Qstart => 'FirstQuestion',
- );
- my %maplength = (
- CODEstart => 'CODElength',
- IDstart => 'IDlength',
- PaperID => 'PaperIDlength',
- FirstName => 'FirstNamelength',
- LastName => 'LastNamelength',
- );
- if (open(my $fh,'<',$fullpath)) {
- my $output;
- my %lettdig = &letter_to_digits();
- my %diglett = reverse(%lettdig);
- my $numletts = scalar(keys(%lettdig));
- my $num = 0;
- while (my $line=<$fh>) {
- $num ++;
- next if (($num == 1) && ($csvoptions{'hdr'} == 1));
- $line =~ s{[\r\n]+$}{};
- my %found;
- my @values = split(/,/,$line);
- my ($qstart,$record);
- for (my $i=0; $i<@values; $i++) {
- if ((($qstart ne '') && ($i > $qstart)) ||
- ($csvbynum{$i} eq 'FirstQuestion')) {
- if ($values[$i] eq '') {
- $values[$i] = $scantronconf{'Qoff'};
- } elsif ($scantronconf{'Qon'} eq 'number') {
- if ($values[$i] =~ /^[A-Ja-j]$/) {
- $values[$i] = $lettdig{uc($values[$i])};
- }
- } elsif ($scantronconf{'Qon'} eq 'letter') {
- if ($values[$i] =~ /^[0-9]$/) {
- $values[$i] = $diglett{$values[$i]};
- }
- } else {
- if ($values[$i] =~ /^[0-9A-Ja-j]$/) {
- my $digit;
- if ($values[$i] =~ /^[A-Ja-j]$/) {
- $digit = $lettdig{uc($values[$i])}-1;
- if ($values[$i] eq 'J') {
- $digit += $numletts;
- }
- } elsif ($values[$i] =~ /^[0-9]$/) {
- $digit = $values[$i]-1;
- if ($values[$i] eq '0') {
- $digit += $numletts;
- }
- }
- my $qval='';
- for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) {
- if ($j == $digit) {
- $qval .= $scantronconf{'Qon'};
- } else {
- $qval .= $scantronconf{'Qoff'};
- }
- }
- $values[$i] = $qval;
- }
- }
- if (length($values[$i]) > $scantronconf{'Qlength'}) {
- $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'});
- }
- my $numblank = $scantronconf{'Qlength'} - length($values[$i]);
- if ($numblank > 0) {
- $values[$i] .= ($scantronconf{'Qoff'} x $numblank);
- }
- if ($csvbynum{$i} eq 'FirstQuestion') {
- $qstart = $i;
- $found{$csvbynum{$i}} = $values[$i];
- } else {
- $found{'FirstQuestion'} .= $values[$i];
- }
- } elsif (exists($csvbynum{$i})) {
- if ($csvoptions{'rem'}) {
- $values[$i] =~ s/^\s+//;
- }
- if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) {
- while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) {
- $values[$i] = '0'.$values[$i];
- }
- }
- $found{$csvbynum{$i}} = $values[$i];
- }
- }
- foreach my $item (@ordered) {
- my $currlength = 1+length($record);
- my $numspaces = $scantronconf{$item} - $currlength;
- if ($numspaces > 0) {
- $record .= (' ' x $numspaces);
- }
- if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) {
- unless ($item eq 'Qstart') {
- if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) {
- $found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}});
- }
- }
- $record .= $found{$mapstart{$item}};
- }
- }
- $output .= "$record\n";
- }
- close($fh);
- if ($output) {
- if (open(my $fh,'>',$fullpath)) {
- print $fh $output;
- close($fh);
- }
- }
- }
- }
- return;
- }
-}
-
-sub letter_to_digits {
- my %lettdig = (
- A => 1,
- B => 2,
- C => 3,
- D => 4,
- E => 5,
- F => 6,
- G => 7,
- H => 8,
- I => 9,
- J => 0,
- );
- return %lettdig;
-}
-
-sub get_scantron_config {
- my ($which,$cdom) = @_;
- my @lines = &get_scantronformat_file($cdom);
- my %config;
- #FIXME probably should move to XML it has already gotten a bit much now
- foreach my $line (@lines) {
- my ($name,$descrip)=split(/:/,$line);
- if ($name ne $which ) { next; }
- chomp($line);
- my @config=split(/:/,$line);
- $config{'name'}=$config[0];
- $config{'description'}=$config[1];
- $config{'CODElocation'}=$config[2];
- $config{'CODEstart'}=$config[3];
- $config{'CODElength'}=$config[4];
- $config{'IDstart'}=$config[5];
- $config{'IDlength'}=$config[6];
- $config{'Qstart'}=$config[7];
- $config{'Qlength'}=$config[8];
- $config{'Qoff'}=$config[9];
- $config{'Qon'}=$config[10];
- $config{'PaperID'}=$config[11];
- $config{'PaperIDlength'}=$config[12];
- $config{'FirstName'}=$config[13];
- $config{'FirstNamelength'}=$config[14];
- $config{'LastName'}=$config[15];
- $config{'LastNamelength'}=$config[16];
- $config{'BubblesPerRow'}=$config[17];
- last;
- }
- return %config;
-}
-
-sub get_scantronformat_file {
- my ($cdom) = @_;
- if ($cdom eq '') {
- $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'};
- }
- my %domconfig = &get_dom('configuration',['scantron'],$cdom);
- my $gottab = 0;
- my @lines;
- if (ref($domconfig{'scantron'}) eq 'HASH') {
- if ($domconfig{'scantron'}{'scantronformat'} ne '') {
- my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'});
- if ($formatfile ne '-1') {
- @lines = split("\n",$formatfile,-1);
- $gottab = 1;
- }
- }
- }
- if (!$gottab) {
- my $confname = $cdom.'-domainconfig';
- my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab';
- my $formatfile = &getfile($default);
- if ($formatfile ne '-1') {
- @lines = split("\n",$formatfile,-1);
- $gottab = 1;
- }
- }
- if (!$gottab) {
- my @domains = ¤t_machine_domains();
- if (grep(/^\Q$cdom\E$/,@domains)) {
- if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) {
- @lines = <$fh>;
- close($fh);
- }
- } else {
- if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) {
- @lines = <$fh>;
- close($fh);
- }
- }
- }
- return @lines;
-}
-
sub removeuploadedurl {
my ($url)=@_;
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
@@ -5077,10 +4856,9 @@ my %cachedtimes=();
my $cachedtime='';
sub load_all_first_access {
- my ($uname,$udom,$ignorecache)=@_;
+ my ($uname,$udom)=@_;
if (($cachedkey eq $uname.':'.$udom) &&
- (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
- (!$ignorecache)) {
+ (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
return;
}
$cachedtime=time;
@@ -5089,7 +4867,7 @@ sub load_all_first_access {
}
sub get_first_access {
- my ($type,$argsymb,$argmap,$ignorecache)=@_;
+ my ($type,$argsymb,$argmap)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);
@@ -5101,7 +4879,7 @@ sub get_first_access {
} else {
$res=$symb;
}
- &load_all_first_access($uname,$udom,$ignorecache);
+ &load_all_first_access($uname,$udom);
return $cachedtimes{"$courseid\0$res"};
}
@@ -5118,7 +4896,12 @@ sub set_first_access {
}
$cachedkey='';
my $firstaccess=&get_first_access($type,$symb,$map);
- if (!$firstaccess) {
+ if ($firstaccess) {
+ &logthis("First access time already set ($firstaccess) when attempting ".
+ "to set new value (type: $type, extent: $res) for $uname:$udom ".
+ "in $courseid");
+ return 'already_set';
+ } else {
my $start = time;
my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
$udom,$uname);
@@ -5131,6 +4914,12 @@ sub set_first_access {
'course.'.$courseid.'.timerinterval.'.$res => $interval,
}
);
+ if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
+ $cachedtimes{"$courseid\0$res"} = $start;
+ }
+ } elsif ($putres ne 'refused') {
+ &logthis("Result: $putres when attempting to set first access time ".
+ "(type: $type, extent: $res) for $uname:$udom in $courseid");
}
return $putres;
}
@@ -6507,7 +6296,7 @@ sub currentdump {
#
my %returnhash=();
#
- if ($rep eq 'unknown_cmd') {
+ if ($rep eq "unknown_cmd") {
# an old lond will not know currentdump
# Do a dump and make it look like a currentdump
my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
@@ -7440,7 +7229,7 @@ sub allowed {
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
- if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$}))
+ if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
&& ($priv eq 'bre')) {
return 'F';
@@ -8101,8 +7890,7 @@ sub get_commblock_resources {
}
}
}
- if ($interval[0] =~ /^(\d+)/) {
- my $timelimit = $1;
+ if ($interval[0] =~ /^\d+$/) {
my $first_access;
if ($type eq 'resource') {
$first_access=&get_first_access($interval[1],$item);
@@ -8112,7 +7900,7 @@ sub get_commblock_resources {
$first_access=&get_first_access($interval[1]);
}
if ($first_access) {
- my $timesup = $first_access+$timelimit;
+ my $timesup = $first_access+$interval[0];
if ($timesup > $now) {
my $activeblock;
foreach my $res (@to_test) {
@@ -9823,19 +9611,14 @@ sub writecoursepref {
sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
- $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
+ $course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);
my $cid='';
if ($context eq 'requestcourses') {
my $can_create = 0;
my ($ownername,$ownerdom) = split(':',$course_owner);
if ($udom eq $ownerdom) {
- my $reload;
- if (($callercontext eq 'auto') &&
- ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
- $reload = 'reload';
- }
- if (&usertools_access($ownername,$ownerdom,$category,$reload,
+ if (&usertools_access($ownername,$ownerdom,$category,undef,
$context)) {
$can_create = 1;
}
@@ -9984,13 +9767,25 @@ sub generate_coursenum {
sub is_course {
my ($cdom, $cnum) = scalar(@_) == 1 ?
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;
-
- return unless $cdom and $cnum;
-
- my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
- '.');
-
- return unless(exists($courses{$cdom.'_'.$cnum}));
+ return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
+ my $uhome=&homeserver($cnum,$cdom);
+ my $iscourse;
+ if (grep { $_ eq $uhome } current_machine_ids()) {
+ $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
+ } else {
+ my $hashid = $cdom.':'.$cnum;
+ ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid);
+ unless (defined($cached)) {
+ my %courses = &courseiddump($cdom, '.', 1, '.', '.',
+ $cnum,undef,undef,'.');
+ $iscourse = 0;
+ if (exists($courses{$cdom.'_'.$cnum})) {
+ $iscourse = 1;
+ }
+ &do_cache_new('iscourse',$hashid,$iscourse,3600);
+ }
+ }
+ return unless($iscourse);
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
}
@@ -10172,7 +9967,7 @@ sub files_not_in_path {
my $filename = $user."savedfiles";
my @return_files;
my $path_part;
- open(IN,'<',LONCAPA::tempdir().$filename);
+ open(IN, '<',LONCAPA::tempdir().$filename);
while (my $line = <IN>) {
#ok, I know it's clunky, but I want it to work
my @paths_and_file = split(m|/|, $line);
@@ -10832,7 +10627,7 @@ sub get_userresdata {
# Parameters:
# $name - Course/user name.
# $domain - Name of the domain the user/course is registered on.
-# $type - Type of thing $name is (must be 'course' or 'user')
+# $type - Type of thing $name is (must be 'course' or 'user'
# @which - Array of names of resources desired.
# Returns:
# The value of the first reasource in @which that is found in the
@@ -10851,44 +10646,13 @@ sub resdata {
}
if (!ref($result)) { return $result; }
foreach my $item (@which) {
- if (ref($item) eq 'ARRAY') {
- if (defined($result->{$item->[0]})) {
- return [$result->{$item->[0]},$item->[1]];
- }
- }
+ if (defined($result->{$item->[0]})) {
+ return [$result->{$item->[0]},$item->[1]];
+ }
}
return undef;
}
-sub get_domain_ltitools {
- my ($cdom) = @_;
- my %ltitools;
- my ($result,$cached)=&is_cached_new('ltitools',$cdom);
- if (defined($cached)) {
- if (ref($result) eq 'HASH') {
- %ltitools = %{$result};
- }
- } else {
- my %domconfig = &get_dom('configuration',['ltitools'],$cdom);
- if (ref($domconfig{'ltitools'}) eq 'HASH') {
- %ltitools = %{$domconfig{'ltitools'}};
- my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom);
- if (ref($encdomconfig{'ltitools'}) eq 'HASH') {
- foreach my $id (keys(%ltitools)) {
- if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') {
- foreach my $item ('key','secret') {
- $ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item};
- }
- }
- }
- }
- }
- my $cachetime = 24*60*60;
- &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);
- }
- return %ltitools;
-}
-
sub get_numsuppfiles {
my ($cnum,$cdom,$ignorecache)=@_;
my $hashid=$cnum.':'.$cdom;
@@ -11344,7 +11108,7 @@ sub metadata {
# if it is a non metadata possible uri return quickly
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
- ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) ||
+ ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
@@ -12938,8 +12702,6 @@ sub clutter {
# &logthis("Got a blank emb style");
}
}
- } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
- $thisfn='/adm/wrapper'.$thisfn;
}
return $thisfn;
}
@@ -13013,15 +12775,17 @@ sub get_dns {
}
my %alldns;
- open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");
- foreach my $dns (<$config>) {
- next if ($dns !~ /^\^(\S*)/x);
- my $line = $1;
- my ($host,$protocol) = split(/:/,$line);
- if ($protocol ne 'https') {
- $protocol = 'http';
+ if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
+ foreach my $dns (<$config>) {
+ next if ($dns !~ /^\^(\S*)/x);
+ my $line = $1;
+ my ($host,$protocol) = split(/:/,$line);
+ if ($protocol ne 'https') {
+ $protocol = 'http';
+ }
+ $alldns{$host} = $protocol;
}
- $alldns{$host} = $protocol;
+ close($config);
}
while (%alldns) {
my ($dns) = sort { $b cmp $a } keys(%alldns);
@@ -13655,6 +13419,11 @@ BEGIN {
}
+# ------------- set default texengine (domain default overrides this)
+{
+ $deftex = LONCAPA::texengine();
+}
+
$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],
'compress_threshold'=> 20_000,
});
@@ -14302,88 +14071,6 @@ Returns:
=back
-=head2 Bubblesheet Configuration
-
-=over 4
-
-=item *
-
-get_scantron_config($which)
-
-$which - the name of the configuration to parse from the file.
-
-Parses and returns the bubblesheet configuration line selected as a
-hash of configuration file fields.
-
-
-Returns:
- If the named configuration is not in the file, an empty
- hash is returned.
-
- a hash with the fields
- name - internal name for the this configuration setup
- description - text to display to operator that describes this config
- CODElocation - if 0 or the string 'none'
- - no CODE exists for this config
- if -1 || the string 'letter'
- - a CODE exists for this config and is
- a string of letters
- Unsupported value (but planned for future support)
- if a positive integer
- - The CODE exists as the first n items from
- the question section of the form
- if the string 'number'
- - The CODE exists for this config and is
- a string of numbers
- CODEstart - (only matter if a CODE exists) column in the line where
- the CODE starts
- CODElength - length of the CODE
- IDstart - column where the student/employee ID starts
- IDlength - length of the student/employee ID info
- Qstart - column where the information from the bubbled
- 'questions' start
- Qlength - number of columns comprising a single bubble line from
- the sheet. (usually either 1 or 10)
- Qon - either a single character representing the character used
- to signal a bubble was chosen in the positional setup, or
- the string 'letter' if the letter of the chosen bubble is
- in the final, or 'number' if a number representing the
- chosen bubble is in the file (1->A 0->J)
- Qoff - the character used to represent that a bubble was
- left blank
- PaperID - if the scanning process generates a unique number for each
- sheet scanned the column that this ID number starts in
- PaperIDlength - number of columns that comprise the unique ID number
- for the sheet of paper
- FirstName - column that the first name starts in
- FirstNameLength - number of columns that the first name spans
- LastName - column that the last name starts in
- LastNameLength - number of columns that the last name spans
- BubblesPerRow - number of bubbles available in each row used to
- bubble an answer. (If not specified, 10 assumed).
-
-
-=item *
-
-get_scantronformat_file($cdom)
-
-$cdom - the course's domain (optional); if not supplied, uses
-domain for current $env{'request.course.id'}.
-
-Returns an array containing lines from the scantron format file for
-the domain of the course.
-
-If a url for a custom.tab file is listed in domain's configuration.db,
-lines are from this file.
-
-Otherwise, if a default.tab has been published in RES space by the
-domainconfig user, lines are from this file.
-
-Otherwise, fall back to getting lines from the legacy file on the
-local server: /home/httpd/lonTabs/default_scantronformat.tab
-
-=back
-
=head2 Resource Subroutines
=over 4
@@ -15075,7 +14762,6 @@ userspace, probably shouldn't be called
formname: same as for userfileupload()
fname: filename (including subdirectories) for the file
parser: if 'parse', will parse (html) file to extract references to objects, links etc.
- if hashref, and context is scantron, will convert csv format to standard format
allfiles: reference to hash used to store objects found by parser
codebase: reference to hash used for codebases of java objects found by parser
thumbwidth: width (pixels) of thumbnail to be created for uploaded image