--- loncom/lonnet/perl/lonnet.pm 2018/05/02 20:33:18 1.1172.2.93.4.11 +++ loncom/lonnet/perl/lonnet.pm 2019/02/03 20:41:27 1.1172.2.93.4.12 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.93.4.11 2018/05/02 20:33:18 raeburn Exp $ +# $Id: lonnet.pm,v 1.1172.2.93.4.12 2019/02/03 20:41:27 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -3404,13 +3404,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 @@ -3600,7 +3603,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); @@ -3609,6 +3612,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; @@ -3849,6 +3855,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); @@ -14051,6 +14297,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 @@ -14742,6 +15070,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