--- loncom/lonnet/perl/lonnet.pm 2018/09/02 23:22:47 1.1172.2.96 +++ loncom/lonnet/perl/lonnet.pm 2019/08/17 17:42:08 1.1172.2.109 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.96 2018/09/02 23:22:47 raeburn Exp $ +# $Id: lonnet.pm,v 1.1172.2.109 2019/08/17 17:42:08 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -74,8 +74,9 @@ use strict; use LWP::UserAgent(); use HTTP::Date; use Image::Magick; +use CGI::Cookie; -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); @@ -603,18 +604,39 @@ sub transfer_profile_to_env { sub check_for_valid_session { my ($r,$name,$userhashref,$domref) = @_; my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); - if ($name eq '') { - $name = 'lonID'; - } - my $lonid=$cookies{$name}; - return undef if (!$lonid); - - my $handle=&LONCAPA::clean_handle($lonid->value); - my $lonidsdir; + my ($lonidsdir,$linkname,$pubname,$secure,$lonid); if ($name eq 'lonDAV') { $lonidsdir=$r->dir_config('lonDAVsessDir'); } else { $lonidsdir=$r->dir_config('lonIDsDir'); + if ($name eq '') { + $name = 'lonID'; + } + } + if ($name eq 'lonID') { + $secure = 'lonSID'; + $linkname = 'lonLinkID'; + $pubname = 'lonPubID'; + if (exists($cookies{$secure})) { + $lonid=$cookies{$secure}; + } elsif (exists($cookies{$name})) { + $lonid=$cookies{$name}; + } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) { + $lonid=$cookies{$linkname}; + } elsif (exists($cookies{$pubname})) { + $lonid=$cookies{$pubname}; + } + } else { + $lonid=$cookies{$name}; + } + return undef if (!$lonid); + + my $handle=&LONCAPA::clean_handle($lonid->value); + if (-l "$lonidsdir/$handle.id") { + my $link = readlink("$lonidsdir/$handle.id"); + if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { + $handle = $1; + } } if (!-e "$lonidsdir/$handle.id") { if ((ref($domref)) && ($name eq 'lonID') && @@ -639,6 +661,7 @@ sub check_for_valid_session { if (!defined($disk_env{'user.name'}) || !defined($disk_env{'user.domain'})) { + untie(%disk_env); return undef; } @@ -646,6 +669,7 @@ sub check_for_valid_session { $userhashref->{'name'} = $disk_env{'user.name'}; $userhashref->{'domain'} = $disk_env{'user.domain'}; } + untie(%disk_env); return $handle; } @@ -670,6 +694,37 @@ sub timed_flock { } } +sub get_sessionfile_vars { + my ($handle,$lonidsdir,$storearr) = @_; + my %returnhash; + unless (ref($storearr) eq 'ARRAY') { + return %returnhash; + } + if (-l "$lonidsdir/$handle.id") { + my $link = readlink("$lonidsdir/$handle.id"); + if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { + $handle = $1; + } + } + if ((-e "$lonidsdir/$handle.id") && + ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { + my ($possuname,$possudom,$possuhome) = ($1,$2,$3); + if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { + if (open(my $idf,'+<',"$lonidsdir/$handle.id")) { + flock($idf,LOCK_SH); + if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", + &GDBM_READER(),0640)) { + foreach my $item (@{$storearr}) { + $returnhash{$item} = $disk_env{$item}; + } + untie(%disk_env); + } + } + } + } + return %returnhash; +} + # ---------------------------------------------------------- Append Environment sub appenv { @@ -951,6 +1006,75 @@ sub find_existing_session { return; } +# check if user's browser sent load balancer cookie and server still has session +# and is not overloaded. +sub check_for_balancer_cookie { + my ($r,$update_mtime) = @_; + my ($otherserver,$cookie); + my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); + if (exists($cookies{'balanceID'})) { + my $balid = $cookies{'balanceID'}; + $cookie=&LONCAPA::clean_handle($balid->value); + my $balancedir=$r->dir_config('lonBalanceDir'); + if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) { + if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) { + my ($possudom,$possuname) = ($1,$2); + my $has_session = 0; + if ((&domain($possudom) ne '') && + (&homeserver($possuname,$possudom) ne 'no_host')) { + my $try_server; + my $opened = open(my $idf,'+<',"$balancedir/$cookie.id"); + if ($opened) { + flock($idf,LOCK_SH); + while (my $line = <$idf>) { + chomp($line); + if (&hostname($line) ne '') { + $try_server = $line; + last; + } + } + close($idf); + if (($try_server) && + (&has_user_session($try_server,$possudom,$possuname))) { + my $lowest_load = 30000; + ($otherserver,$lowest_load) = + &compare_server_load($try_server,undef,$lowest_load); + if ($otherserver ne '' && $lowest_load < 100) { + $has_session = 1; + } else { + undef($otherserver); + } + } + } + } + if ($has_session) { + if ($update_mtime) { + my $atime = my $mtime = time; + utime($atime,$mtime,"$balancedir/$cookie.id"); + } + } else { + unlink("$balancedir/$cookie.id"); + } + } + } + } + return ($otherserver,$cookie); +} + +sub delbalcookie { + my ($cookie,$balancer) =@_; + if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { + my ($udom,$uname) = ($1,$2); + my $uprimary_id = &domain($udom,'primary'); + my $uintdom = &internet_dom($uprimary_id); + my $intdom = &internet_dom($balancer); + my $serverhomedom = &host_domain($balancer); + if (($uintdom ne '') && ($uintdom eq $intdom)) { + return &reply("delbalcookie:$cookie",$balancer); + } + } +} + # -------------------------------- ask if server already has a session for user sub has_user_session { my ($lonid,$udom,$uname) = @_; @@ -1288,7 +1412,7 @@ sub get_lonbalancer_config { sub check_loadbalancing { my ($uname,$udom,$caller) = @_; my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, - $rule_in_effect,$offloadto,$otherserver); + $rule_in_effect,$offloadto,$otherserver,$setcookie); my $lonhost = $perlvar{'lonHostID'}; my @hosts = ¤t_machine_ids(); my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); @@ -1315,7 +1439,7 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = + ($is_balancer,$currtargets,$currrules,$setcookie) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1376,7 +1500,7 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = + ($is_balancer,$currtargets,$currrules,$setcookie) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1442,20 +1566,22 @@ sub check_loadbalancing { $is_balancer = 0; if ($uname ne '' && $udom ne '') { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { - &appenv({'user.loadbalexempt' => $lonhost, 'user.loadbalcheck.time' => time}); } } } } + unless ($homeintdom) { + undef($setcookie); + } } - return ($is_balancer,$otherserver); + return ($is_balancer,$otherserver,$setcookie); } sub check_balancer_result { my ($result,@hosts) = @_; - my ($is_balancer,$currtargets,$currrules); + my ($is_balancer,$currtargets,$currrules,$setcookie); if (ref($result) eq 'HASH') { if ($result->{'lonhost'} ne '') { my $currbalancer = $result->{'lonhost'}; @@ -1471,12 +1597,13 @@ sub check_balancer_result { $is_balancer = 1; $currrules = $result->{$key}{'rules'}; $currtargets = $result->{$key}{'targets'}; + $setcookie = $result->{$key}{'cookie'}; last; } } } } - return ($is_balancer,$currtargets,$currrules); + return ($is_balancer,$currtargets,$currrules,$setcookie); } sub get_loadbalancer_targets { @@ -2193,6 +2320,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') { @@ -2256,6 +2386,65 @@ sub get_domain_defaults { return %domdefaults; } +sub get_dom_cats { + my ($dom) = @_; + return unless (&domain($dom)); + my ($cats,$cached)=&is_cached_new('cats',$dom); + unless (defined($cached)) { + my %domconfig = &get_dom('configuration',['coursecategories'],$dom); + if (ref($domconfig{'coursecategories'}) eq 'HASH') { + if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') { + %{$cats} = %{$domconfig{'coursecategories'}{'cats'}}; + } else { + $cats = {}; + } + } else { + $cats = {}; + } + &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600); + } + return $cats; +} + +sub get_dom_instcats { + my ($dom) = @_; + return unless (&domain($dom)); + my ($instcats,$cached)=&is_cached_new('instcats',$dom); + unless (defined($cached)) { + my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order); + my $totcodes = &retrieve_instcodes(\%coursecodes,$dom); + if ($totcodes > 0) { + my $caller = 'global'; + if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes, + \@codetitles,\%cat_titles,\%cat_order) eq 'ok') { + $instcats = { + codes => \%codes, + codetitles => \@codetitles, + cat_titles => \%cat_titles, + cat_order => \%cat_order, + }; + &do_cache_new('instcats',$dom,$instcats,3600); + } + } + } + return $instcats; +} + +sub retrieve_instcodes { + my ($coursecodes,$dom) = @_; + my $totcodes; + my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course'); + foreach my $course (keys(%courses)) { + if (ref($courses{$course}) eq 'HASH') { + if ($courses{$course}{'inst_code'} ne '') { + $$coursecodes{$course} = $courses{$course}{'inst_code'}; + $totcodes ++; + } + } + } + return $totcodes; +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -2840,8 +3029,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); @@ -2858,7 +3046,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 { @@ -2878,6 +3089,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 { @@ -3338,13 +3615,16 @@ 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, or ''. +# canceloverwrite, scantron 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) +# $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 }). # $allfiles - reference to hash for embedded objects # $codebase - reference to hash for codebase of java objects # $desuname - username for permanent storage of uploaded file @@ -3534,7 +3814,7 @@ sub finishuserfileupload { } } } - if ($parser eq 'parse') { + if (($context ne 'scantron') && ($parser eq 'parse')) { if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { my $parse_result = &extract_embedded_items($filepath.'/'.$file, $allfiles,$codebase); @@ -3543,6 +3823,9 @@ 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; @@ -3783,6 +4066,246 @@ 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); @@ -4805,7 +5328,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); @@ -4818,6 +5346,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; } @@ -10999,6 +11533,7 @@ sub add_prefix_and_part { my %metaentry; my %importedpartids; +my %importedrespids; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); @@ -11026,9 +11561,11 @@ sub metadata { } { # Imported parts would go here - my %importedids=(); - my @origfileimportpartids=(); + my @origfiletagids=(); my $importedparts=0; + +# Imported responseids would go here + my $importedresponses=0; # # Is this a recursive call for a library? # @@ -11123,8 +11660,37 @@ 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'}); @@ -11133,12 +11699,15 @@ 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 ($#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 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 imported file @@ -11252,20 +11821,48 @@ sub metadata { grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); $metaentry{':packages'} = join(',',@uniq_packages); - if ($importedparts) { + if (($importedresponses) || ($importedparts)) { + if ($importedparts) { # We had imported parts and need to rebuild partorder - $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{':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{':keys'} = join(',',keys(%metathesekeys)); @@ -12487,6 +13084,27 @@ sub default_login_domain { return $domain; } +sub shared_institution { + my ($dom) = @_; + my $same_intdom; + my $hostintdom = &internet_dom($perlvar{'lonHostID'}); + if ($hostintdom ne '') { + my %iphost = &get_iphost(); + my $primary_id = &domain($dom,'primary'); + my $primary_ip = &get_host_ip($primary_id); + if (ref($iphost{$primary_ip}) eq 'ARRAY') { + foreach my $id (@{$iphost{$primary_ip}}) { + my $intdom = &internet_dom($id); + if ($intdom eq $hostintdom) { + $same_intdom = 1; + last; + } + } + } + } + return $same_intdom; +} + # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -12637,12 +13255,12 @@ sub get_dns { &$func(\@content,$hashref); return; } - close($config); my $which = (split('/',$url))[3]; &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); - open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab"); - my @content = <$config>; - &$func(\@content,$hashref); + if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) { + my @content = <$config>; + &$func(\@content,$hashref); + } return; } @@ -13254,6 +13872,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, }); @@ -13901,6 +14524,88 @@ 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 @@ -14592,6 +15297,7 @@ 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