version 1.1172.2.93.4.12, 2019/02/03 20:41:27
|
version 1.1172.2.96, 2018/09/02 23:22:47
|
Line 1700 sub get_dom {
|
Line 1700 sub get_dom {
|
} |
} |
} |
} |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
my $rep; |
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
if ($namespace =~ /^enc/) { |
|
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); |
|
} else { |
|
$rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
|
} |
|
my %returnhash; |
my %returnhash; |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
return %returnhash; |
return %returnhash; |
Line 1749 sub put_dom {
|
Line 1744 sub put_dom {
|
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
if ($namespace =~ /^enc/) { |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); |
|
} else { |
|
return &reply("putdom:$udom:$namespace:$items",$uhome); |
|
} |
|
} else { |
} else { |
&logthis("put_dom failed - no homeserver and/or domain"); |
&logthis("put_dom failed - no homeserver and/or domain"); |
} |
} |
Line 1844 sub inst_directory_query {
|
Line 1835 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,$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:". |
my $queryid=&reply("querysend:instdirsearch:". |
&escape($srch->{'srchby'}).':'. |
&escape($srch->{'srchby'}).':'. |
&escape($srch->{'srchterm'}).':'. |
&escape($srch->{'srchterm'}).':'. |
Line 1896 sub usersearch {
|
Line 1876 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,$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 $host=&hostname($tryserver); |
my $queryid= |
my $queryid= |
&reply("querysend:".&escape($query).':'. |
&reply("querysend:".&escape($query).':'. |
Line 2285 sub get_domain_defaults {
|
Line 2256 sub get_domain_defaults {
|
return %domdefaults; |
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 |
# --------------------------------------------------- Assign a key to a student |
|
|
sub assign_access_key { |
sub assign_access_key { |
Line 3061 sub can_edit_resource {
|
Line 3016 sub can_edit_resource {
|
$forceedit = 1; |
$forceedit = 1; |
} |
} |
$cfile = $resurl; |
$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$}) { |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
$incourse = 1; |
$incourse = 1; |
if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
Line 3093 sub can_edit_resource {
|
Line 3040 sub can_edit_resource {
|
$forceedit = 1; |
$forceedit = 1; |
} |
} |
$cfile = $resurl; |
$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'})) { |
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { |
$incourse = 1; |
$incourse = 1; |
$forceview = 1; |
$forceview = 1; |
Line 3110 sub can_edit_resource {
|
Line 3049 sub can_edit_resource {
|
$cfile = &clutter($res); |
$cfile = &clutter($res); |
} else { |
} else { |
$cfile = $env{'form.suppurl'}; |
$cfile = $env{'form.suppurl'}; |
my $escfile = &unescape($cfile); |
$cfile =~ s{^http://}{}; |
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
$cfile = '/adm/wrapper/ext/'.$cfile; |
$cfile = '/adm/wrapper'.$escfile; |
|
} else { |
|
$escfile =~ s{^http://}{}; |
|
$cfile = &escape("/adm/wrapper/ext/$escfile"); |
|
} |
|
} |
} |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
Line 3404 sub resizeImage {
|
Line 3338 sub resizeImage {
|
# input: $formname - the contents of the file are in $env{"form.$formname"} |
# input: $formname - the contents of the file are in $env{"form.$formname"} |
# the desired filename is in $env{"form.$formname.filename"} |
# the desired filename is in $env{"form.$formname.filename"} |
# $context - possible values: coursedoc, existingfile, overwrite, |
# $context - possible values: coursedoc, existingfile, overwrite, |
# canceloverwrite, scantron or ''. |
# canceloverwrite, or ''. |
# if 'coursedoc': upload to the current course |
# if 'coursedoc': upload to the current course |
# if 'existingfile': write file to tmp/overwrites directory |
# if 'existingfile': write file to tmp/overwrites directory |
# if 'canceloverwrite': delete file written to tmp/overwrites directory |
# if 'canceloverwrite': delete file written to tmp/overwrites directory |
# $context is passed as argument to &finishuserfileupload |
# $context is passed as argument to &finishuserfileupload |
# $subdir - directory in userfile to store the file into |
# $subdir - directory in userfile to store the file into |
# $parser - instruction to parse file for objects ($parser = parse) or |
# $parser - instruction to parse file for objects ($parser = parse) |
# 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 }). |
|
# $allfiles - reference to hash for embedded objects |
# $allfiles - reference to hash for embedded objects |
# $codebase - reference to hash for codebase of java objects |
# $codebase - reference to hash for codebase of java objects |
# $desuname - username for permanent storage of uploaded file |
# $desuname - username for permanent storage of uploaded file |
Line 3454 sub userfileupload {
|
Line 3385 sub userfileupload {
|
} else { |
} else { |
$docudom = $env{'user.domain'}; |
$docudom = $env{'user.domain'}; |
} |
} |
if ($destuname =~ /^$match_username$/) { |
if ($destuname =~ /^$match_username$/) { |
$docuname = $destuname; |
$docuname = $destuname; |
} else { |
} else { |
$docuname = $env{'user.name'}; |
$docuname = $env{'user.name'}; |
Line 3603 sub finishuserfileupload {
|
Line 3534 sub finishuserfileupload {
|
} |
} |
} |
} |
} |
} |
if (($context ne 'scantron') && ($parser eq 'parse')) { |
if ($parser eq 'parse') { |
if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { |
if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { |
my $parse_result = &extract_embedded_items($filepath.'/'.$file, |
my $parse_result = &extract_embedded_items($filepath.'/'.$file, |
$allfiles,$codebase); |
$allfiles,$codebase); |
Line 3612 sub finishuserfileupload {
|
Line 3543 sub finishuserfileupload {
|
' for embedded media: '.$parse_result); |
' 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+$/)) { |
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
my $input = $filepath.'/'.$file; |
my $input = $filepath.'/'.$file; |
Line 3855 sub embedded_dependency {
|
Line 3783 sub embedded_dependency {
|
return; |
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 { |
sub removeuploadedurl { |
my ($url)=@_; |
my ($url)=@_; |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
Line 5077 my %cachedtimes=();
|
Line 4765 my %cachedtimes=();
|
my $cachedtime=''; |
my $cachedtime=''; |
|
|
sub load_all_first_access { |
sub load_all_first_access { |
my ($uname,$udom,$ignorecache)=@_; |
my ($uname,$udom)=@_; |
if (($cachedkey eq $uname.':'.$udom) && |
if (($cachedkey eq $uname.':'.$udom) && |
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) && |
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) { |
(!$ignorecache)) { |
|
return; |
return; |
} |
} |
$cachedtime=time; |
$cachedtime=time; |
Line 5089 sub load_all_first_access {
|
Line 4776 sub load_all_first_access {
|
} |
} |
|
|
sub get_first_access { |
sub get_first_access { |
my ($type,$argsymb,$argmap,$ignorecache)=@_; |
my ($type,$argsymb,$argmap)=@_; |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
if ($argsymb) { $symb=$argsymb; } |
if ($argsymb) { $symb=$argsymb; } |
my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
Line 5101 sub get_first_access {
|
Line 4788 sub get_first_access {
|
} else { |
} else { |
$res=$symb; |
$res=$symb; |
} |
} |
&load_all_first_access($uname,$udom,$ignorecache); |
&load_all_first_access($uname,$udom); |
return $cachedtimes{"$courseid\0$res"}; |
return $cachedtimes{"$courseid\0$res"}; |
} |
} |
|
|
Line 6507 sub currentdump {
|
Line 6194 sub currentdump {
|
# |
# |
my %returnhash=(); |
my %returnhash=(); |
# |
# |
if ($rep eq 'unknown_cmd') { |
if ($rep eq "unknown_cmd") { |
# an old lond will not know currentdump |
# an old lond will not know currentdump |
# Do a dump and make it look like a currentdump |
# Do a dump and make it look like a currentdump |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
Line 7440 sub allowed {
|
Line 7127 sub allowed {
|
|
|
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
# Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
&& ($priv eq 'bre')) { |
&& ($priv eq 'bre')) { |
return 'F'; |
return 'F'; |
Line 8101 sub get_commblock_resources {
|
Line 7788 sub get_commblock_resources {
|
} |
} |
} |
} |
} |
} |
if ($interval[0] =~ /^(\d+)/) { |
if ($interval[0] =~ /^\d+$/) { |
my $timelimit = $1; |
|
my $first_access; |
my $first_access; |
if ($type eq 'resource') { |
if ($type eq 'resource') { |
$first_access=&get_first_access($interval[1],$item); |
$first_access=&get_first_access($interval[1],$item); |
Line 8112 sub get_commblock_resources {
|
Line 7798 sub get_commblock_resources {
|
$first_access=&get_first_access($interval[1]); |
$first_access=&get_first_access($interval[1]); |
} |
} |
if ($first_access) { |
if ($first_access) { |
my $timesup = $first_access+$timelimit; |
my $timesup = $first_access+$interval[0]; |
if ($timesup > $now) { |
if ($timesup > $now) { |
my $activeblock; |
my $activeblock; |
foreach my $res (@to_test) { |
foreach my $res (@to_test) { |
Line 9979 sub generate_coursenum {
|
Line 9665 sub generate_coursenum {
|
sub is_course { |
sub is_course { |
my ($cdom, $cnum) = scalar(@_) == 1 ? |
my ($cdom, $cnum) = scalar(@_) == 1 ? |
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; |
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; |
|
return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)); |
return unless $cdom and $cnum; |
my $uhome=&homeserver($cnum,$cdom); |
|
my $iscourse; |
my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef, |
if (grep { $_ eq $uhome } current_machine_ids()) { |
'.'); |
$iscourse = &LONCAPA::Lond::is_course($cdom,$cnum); |
|
} else { |
return unless(exists($courses{$cdom.'_'.$cnum})); |
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; |
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; |
} |
} |
|
|
Line 10167 sub files_not_in_path {
|
Line 9865 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::tempdir().$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 10827 sub get_userresdata {
|
Line 10525 sub get_userresdata {
|
# Parameters: |
# Parameters: |
# $name - Course/user name. |
# $name - Course/user name. |
# $domain - Name of the domain the user/course is registered on. |
# $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. |
# @which - Array of names of resources desired. |
# Returns: |
# Returns: |
# The value of the first reasource in @which that is found in the |
# The value of the first reasource in @which that is found in the |
Line 10846 sub resdata {
|
Line 10544 sub resdata {
|
} |
} |
if (!ref($result)) { return $result; } |
if (!ref($result)) { return $result; } |
foreach my $item (@which) { |
foreach my $item (@which) { |
if (ref($item) eq 'ARRAY') { |
if (defined($result->{$item->[0]})) { |
if (defined($result->{$item->[0]})) { |
return [$result->{$item->[0]},$item->[1]]; |
return [$result->{$item->[0]},$item->[1]]; |
} |
} |
|
} |
|
} |
} |
return undef; |
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 { |
sub get_numsuppfiles { |
my ($cnum,$cdom,$ignorecache)=@_; |
my ($cnum,$cdom,$ignorecache)=@_; |
my $hashid=$cnum.':'.$cdom; |
my $hashid=$cnum.':'.$cdom; |
Line 11332 sub add_prefix_and_part {
|
Line 10999 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,$liburi,$prefix,$depthcount)=@_; |
$uri=&declutter($uri); |
$uri=&declutter($uri); |
# if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
if (($uri eq '') || |
if (($uri eq '') || |
(($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
return undef; |
return undef; |
} |
} |
Line 11360 sub metadata {
|
Line 11026 sub metadata {
|
} |
} |
{ |
{ |
# Imported parts would go here |
# Imported parts would go here |
my @origfiletagids=(); |
my %importedids=(); |
|
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 11459 sub metadata {
|
Line 11123 sub metadata {
|
my $dir=$filename; |
my $dir=$filename; |
$dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
$location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
|
|
my $importid=$token->[2]->{'id'}; |
|
my $importmode=$token->[2]->{'importmode'}; |
my $importmode=$token->[2]->{'importmode'}; |
# |
|
# Check metadata for imported file to |
|
# see if it contained response items |
|
# |
|
my %currmetaentry = %metaentry; |
|
my $libresponseorder = &metadata($location,'responseorder'); |
|
my $origfile; |
|
if ($libresponseorder ne '') { |
|
if ($#origfiletagids<0) { |
|
undef(%importedrespids); |
|
undef(%importedpartids); |
|
} |
|
@{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder); |
|
if (@{$importedrespids{$importid}} > 0) { |
|
$importedresponses = 1; |
|
# We need to get the original file and the imported file to get the response order correct |
|
# Load and inspect original file |
|
if ($#origfiletagids<0) { |
|
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
|
$origfile=&getfile($origfilelocation); |
|
@origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
} |
|
} |
|
} |
|
# Do not overwrite contents of %metaentry hash for resource itself with |
|
# hash populated for imported library file |
|
%metaentry = %currmetaentry; |
|
undef(%currmetaentry); |
|
if ($importmode eq 'problem') { |
if ($importmode eq 'problem') { |
# Import as problem/response |
# Import as problem/response |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
Line 11498 sub metadata {
|
Line 11133 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 if we didn't do that already |
# Load and inspect original file |
if ($#origfiletagids<0) { |
if ($#origfileimportpartids<0) { |
undef(%importedrespids); |
undef(%importedpartids); |
undef(%importedpartids); |
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
if ($origfile eq '') { |
my $origfile=&getfile($origfilelocation); |
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
@origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
$origfile=&getfile($origfilelocation); |
|
@origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
} |
|
} |
} |
|
|
# Load and inspect imported file |
# Load and inspect imported file |
Line 11620 sub metadata {
|
Line 11252 sub metadata {
|
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
$metaentry{':packages'} = join(',',@uniq_packages); |
$metaentry{':packages'} = join(',',@uniq_packages); |
|
|
if (($importedresponses) || ($importedparts)) { |
if ($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 ($importedresponses) { |
if ($origfileimportpartids[$index] eq 'part') { |
# We had imported responses and need to rebuild responseorder |
# original part, part of the problem |
$metaentry{':responseorder'}=''; |
$metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; |
$metathesekeys{'responseorder'}=1; |
} else { |
} |
# we have imported parts at this position |
for (my $index=0;$index<$#origfiletagids;$index+=2) { |
$metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; |
my $origid = $origfiletagids[$index+1]; |
} |
if ($origfiletagids[$index] eq 'part') { |
} |
# Original part, part of the problem |
$metaentry{':partorder'}=~s/^\,//; |
if ($importedparts) { |
|
$metaentry{':partorder'}.=','.$origid; |
|
} |
|
} elsif ($origfiletagids[$index] eq 'import') { |
|
if ($importedparts) { |
|
# We have imported parts at this position |
|
$metaentry{':partorder'}.=','.$importedpartids{$origid}; |
|
} |
|
if ($importedresponses) { |
|
# We have imported responses at this position |
|
if (ref($importedrespids{$origid}) eq 'ARRAY') { |
|
$metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}}); |
|
} |
|
} |
|
} else { |
|
# Original response item, part of the problem |
|
if ($importedresponses) { |
|
$metaentry{':responseorder'}.=','.$origid; |
|
} |
|
} |
|
} |
|
if ($importedparts) { |
|
$metaentry{':partorder'}=~s/^\,//; |
|
} |
|
if ($importedresponses) { |
|
$metaentry{':responseorder'}=~s/^\,//; |
|
} |
|
} |
} |
|
|
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
Line 12933 sub clutter {
|
Line 12537 sub clutter {
|
# &logthis("Got a blank emb style"); |
# &logthis("Got a blank emb style"); |
} |
} |
} |
} |
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { |
|
$thisfn='/adm/wrapper'.$thisfn; |
|
} |
} |
return $thisfn; |
return $thisfn; |
} |
} |
Line 13008 sub get_dns {
|
Line 12610 sub get_dns {
|
} |
} |
|
|
my %alldns; |
my %alldns; |
open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); |
if (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; |
my ($host,$protocol) = split(/:/,$line); |
my ($host,$protocol) = split(/:/,$line); |
if ($protocol ne 'https') { |
if ($protocol ne 'https') { |
$protocol = 'http'; |
$protocol = 'http'; |
|
} |
|
$alldns{$host} = $protocol; |
} |
} |
$alldns{$host} = $protocol; |
close($config); |
} |
} |
while (%alldns) { |
while (%alldns) { |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
Line 14297 Returns:
|
Line 13901 Returns:
|
|
|
=back |
=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 |
=head2 Resource Subroutines |
|
|
=over 4 |
=over 4 |
Line 15070 userspace, probably shouldn't be called
|
Line 14592 userspace, probably shouldn't be called
|
formname: same as for userfileupload() |
formname: same as for userfileupload() |
fname: filename (including subdirectories) for the file |
fname: filename (including subdirectories) for the file |
parser: if 'parse', will parse (html) file to extract references to objects, links etc. |
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 |
allfiles: reference to hash used to store objects found by parser |
codebase: reference to hash used for codebases of java 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 |
thumbwidth: width (pixels) of thumbnail to be created for uploaded image |