--- loncom/lonnet/perl/lonnet.pm 2020/07/17 23:36:00 1.1172.2.93.4.13 +++ loncom/lonnet/perl/lonnet.pm 2018/09/02 23:22:47 1.1172.2.96 @@ -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.96 2018/09/02 23:22:47 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -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).':'. @@ -2285,22 +2256,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 { @@ -3061,14 +3016,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 +3040,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 +3049,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 +3338,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 +3385,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 +3534,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 +3543,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 +3783,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 +4765,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 +4776,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 +4788,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"}; } @@ -6507,7 +6194,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 +7127,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 +7788,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 +7798,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 +9509,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 +9665,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 +9865,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 = ) { #ok, I know it's clunky, but I want it to work my @paths_and_file = split(m|/|, $line); @@ -10832,7 +10525,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 +10544,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; @@ -11337,14 +10999,13 @@ sub add_prefix_and_part { my %metaentry; my %importedpartids; -my %importedrespids; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); # 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; } @@ -11365,11 +11026,9 @@ sub metadata { } { # Imported parts would go here - my @origfiletagids=(); + my %importedids=(); + my @origfileimportpartids=(); my $importedparts=0; - -# Imported responseids would go here - my $importedresponses=0; # # Is this a recursive call for a library? # @@ -11464,37 +11123,8 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - - my $importid=$token->[2]->{'id'}; + 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') { # Import as problem/response $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); @@ -11503,15 +11133,12 @@ sub metadata { $importedparts=1; # 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 -# Load and inspect original file if we didn't do that already - if ($#origfiletagids<0) { - undef(%importedrespids); - undef(%importedpartids); - if ($origfile eq '') { - my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); - $origfile=&getfile($origfilelocation); - @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); - } +# Load and inspect original file + if ($#origfileimportpartids<0) { + undef(%importedpartids); + my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); + my $origfile=&getfile($origfilelocation); + @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); } # Load and inspect imported file @@ -11625,48 +11252,20 @@ sub metadata { grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); $metaentry{':packages'} = join(',',@uniq_packages); - if (($importedresponses) || ($importedparts)) { - if ($importedparts) { + if ($importedparts) { # We had imported parts and need to rebuild partorder - $metaentry{':partorder'}=''; - $metathesekeys{'partorder'}=1; - } - if ($importedresponses) { -# We had imported responses and need to rebuild responseorder - $metaentry{':responseorder'}=''; - $metathesekeys{'responseorder'}=1; - } - for (my $index=0;$index<$#origfiletagids;$index+=2) { - my $origid = $origfiletagids[$index+1]; - if ($origfiletagids[$index] eq 'part') { -# Original part, part of the problem - if ($importedparts) { - $metaentry{':partorder'}.=','.$origid; - } - } elsif ($origfiletagids[$index] eq 'import') { - if ($importedparts) { -# We have imported parts at this position - $metaentry{':partorder'}.=','.$importedpartids{$origid}; - } - if ($importedresponses) { -# We have imported responses at this position - if (ref($importedrespids{$origid}) eq 'ARRAY') { - $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}}); - } - } - } else { -# Original response item, part of the problem - if ($importedresponses) { - $metaentry{':responseorder'}.=','.$origid; - } - } - } - if ($importedparts) { - $metaentry{':partorder'}=~s/^\,//; - } - if ($importedresponses) { - $metaentry{':responseorder'}=~s/^\,//; - } + $metaentry{':partorder'}=''; + $metathesekeys{'partorder'}=1; + for (my $index=0;$index<$#origfileimportpartids;$index+=2) { + if ($origfileimportpartids[$index] eq 'part') { +# original part, part of the problem + $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; + } else { +# we have imported parts at this position + $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; + } + } + $metaentry{':partorder'}=~s/^\,//; } $metaentry{':keys'} = join(',',keys(%metathesekeys)); @@ -12938,8 +12537,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 +12610,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); @@ -14302,88 +13901,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 +14592,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