[BACK]Return to grades.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / homework

Diff for /loncom/homework/grades.pm between versions 1.494 and 1.522

version 1.494, 2007/11/16 08:52:15 version 1.522, 2008/05/24 00:34:12
Line 47  use LONCAPA; Line 47  use LONCAPA;
 use POSIX qw(floor);  use POSIX qw(floor);
   
   
   
 my %perm=();  my %perm=();
 my %bubble_lines_per_response = ();     # no. bubble lines for each response.  
                                    # index is "symb.part_id"  
   
 my %first_bubble_line = (); # First bubble line no. for each bubble.  #  These variables are used to recover from ssi errors
   
 # Save and restore the bubble lines array to the form env.  my $ssi_retries = 5;
   my $ssi_error;
   my $ssi_error_resource;
   my $ssi_error_message;
   
   
 sub save_bubble_lines {  #  Do an ssi with retries:
     foreach my $line (keys(%bubble_lines_per_response)) {  #  While I'd love to factor out this with the vesrion in lonprintout,
  $env{"form.scantron.bubblelines.$line"}  = $bubble_lines_per_response{$line};  #  that would either require a data coupling between modules, which I refuse to perpetuate
  $env{"form.scantron.first_bubble_line.$line"} =  #  (there's quite enough of that already), or would require the invention of another infrastructure
     $first_bubble_line{$line};  #  I'm not quite ready to invent (e.g. an ssi_with_retry object).
     }  #
 }  # At least the logic that drives this has been pulled out into loncommon.
   
   
 sub restore_bubble_lines {  #
     my $line = 0;  #   ssi_with_retries - Does the server side include of a resource.
     %bubble_lines_per_response = ();  #                      if the ssi call returns an error we'll retry it up to
     while ($env{"form.scantron.bubblelines.$line"}) {  #                      the number of times requested by the caller.
  my $value = $env{"form.scantron.bubblelines.$line"};  #                      If we still have a proble, no text is appended to the
  $bubble_lines_per_response{$line} = $value;  #                      output and we set some global variables.
  $first_bubble_line{$line}  =  #                      to indicate to the caller an SSI error occurred.  
     $env{"form.scantron.first_bubble_line.$line"};  #                      All of this is supposed to deal with the issues described
  $line++;  #                      in LonCAPA BZ 5631 see:
   #                      http://bugs.lon-capa.org/show_bug.cgi?id=5631
   #                      by informing the user that this happened.
   #
   # Parameters:
   #   resource   - The resource to include.  This is passed directly, without
   #                interpretation to lonnet::ssi.
   #   form       - The form hash parameters that guide the interpretation of the resource
   #                
   #   retries    - Number of retries allowed before giving up completely.
   # Returns:
   #   On success, returns the rendered resource identified by the resource parameter.
   # Side Effects:
   #   The following global variables can be set:
   #    ssi_error                - If an unrecoverable error occurred this becomes true.
   #                               It is up to the caller to initialize this to false
   #                               if desired.
   #    ssi_error_resource  - If an unrecoverable error occurred, this is the value
   #                               of the resource that could not be rendered by the ssi
   #                               call.
   #    ssi_error_message   - The error string fetched from the ssi response
   #                               in the event of an error.
   #
   sub ssi_with_retries {
       my ($resource, $retries, %form) = @_;
       my ($content, $response) = &Apache::loncommon::ssi_with_retries($resource, $retries, %form);
       if ($response->is_error) {
    $ssi_error          = 1;
    $ssi_error_resource = $resource;
    $ssi_error_message  = $response->code . " " . $response->message;
     }      }
   
 }      return $content;
   
 #  Given the parsed scanline, get the response for   
 #  'answer' number n:  
   
 sub get_response_bubbles {  
     my ($parsed_line, $response)  = @_;  
   
   
     my $bubble_line = $first_bubble_line{$response-1} +1;  
     my $bubble_lines= $bubble_lines_per_response{$response-1};  
       
     my $selected = "";  
   
     for (my $bline = 0; $bline < $bubble_lines; $bline++) {  
  $selected .= $$parsed_line{"scantron.$bubble_line.answer"}.":";  
  $bubble_line++;  
     }  
     return $selected;  
 }  }
   #
   #  Prodcuces an ssi retry failure error message to the user:
   #
   
   sub ssi_print_error {
 # ----- These first few routines are general use routines.----      my ($r) = @_;
       my $helpurl = &Apache::loncommon::top_nav_help('Helpdesk');
 # Return the number of occurences of a pattern in a string.      $r->print('
   <br />
 sub occurence_count {  <h2>'.&mt('An unrecoverable network error occurred:').'</h2>
     my ($string, $pattern) = @_;  <p>
   '.&mt('Unable to retrieve a resource from a server:').'<br />
     my @matches = ($string =~ /$pattern/g);  '.&mt('Resource:').' '.$ssi_error_resource.'<br />
   '.&mt('Error:').' '.$ssi_error_message.'
     return scalar(@matches);  </p>
 }  <p>'.
   &mt('It is recommended that you try again later, as this error may mean the server was just temporarily unavailable, or is down for maintenance.').'<br />'.
   &mt('If the error persists, please contact the [_1] for assistance.',$helpurl).
 # Take a string known to have digits and convert all the  '</p>');
 # digits into letters in the range J,A..I.      return;
   
 sub digits_to_letters {  
     my ($input) = @_;  
   
     my @alphabet = ('J', 'A'..'I');  
   
     my @input    = split(//, $input);  
     my $output ='';  
     for (my $i = 0; $i < scalar(@input); $i++) {  
  if ($input[$i] =~ /\d/) {  
     $output .= $alphabet[$input[$i]];  
  } else {  
     $output .= $input[$i];  
  }  
     }  
     return $output;  
 }  }
   
 #  #
Line 283  sub reset_caches { Line 284  sub reset_caches {
   
  my (undef,undef,$url)=&Apache::lonnet::decode_symb($symb);   my (undef,undef,$url)=&Apache::lonnet::decode_symb($symb);
  $url=&Apache::lonnet::clutter($url);   $url=&Apache::lonnet::clutter($url);
  my $subresult=&Apache::lonnet::ssi($url,   my $subresult=&ssi_with_retries($url, $ssi_retries,
    ('grade_target' => 'analyze'),     ('grade_target' => 'analyze',
    ('grade_domain' => $udom),      'grade_domain' => $udom,
    ('grade_symb' => $symb),      'grade_symb' => $symb,
    ('grade_courseid' =>       'grade_courseid' => 
     $env{'request.course.id'}),      $env{'request.course.id'},
    ('grade_username' => $uname));      'grade_username' => $uname));
  (undef,$subresult)=split(/_HASH_REF__/,$subresult,2);   (undef,$subresult)=split(/_HASH_REF__/,$subresult,2);
  my %analyze=&Apache::lonnet::str2hash($subresult);   my %analyze=&Apache::lonnet::str2hash($subresult);
  return $analyze_cache{$key} = \%analyze;   return $analyze_cache{$key} = \%analyze;
Line 1841  sub download_all_link { Line 1842  sub download_all_link {
  join("\n",&Apache::loncommon::get_env_multiple('form.vPart'));   join("\n",&Apache::loncommon::get_env_multiple('form.vPart'));
   
     my $identifier = &Apache::loncommon::get_cgi_id();      my $identifier = &Apache::loncommon::get_cgi_id();
     &Apache::lonnet::appenv('cgi.'.$identifier.'.students' => $all_students,      &Apache::lonnet::appenv({'cgi.'.$identifier.'.students' => $all_students,
                             'cgi.'.$identifier.'.symb' => $symb,                               'cgi.'.$identifier.'.symb' => $symb,
                             'cgi.'.$identifier.'.parts' => $parts,);                               'cgi.'.$identifier.'.parts' => $parts,});
     $r->print('<a href="/cgi-bin/multidownload.pl?'.$identifier.'">'.      $r->print('<a href="/cgi-bin/multidownload.pl?'.$identifier.'">'.
       &mt('Download All Submitted Documents').'</a>');        &mt('Download All Submitted Documents').'</a>');
     return      return
Line 2767  sub check_and_remove_from_queue { Line 2768  sub check_and_remove_from_queue {
   
 sub handback_files {  sub handback_files {
     my ($request,$symb,$stuname,$domain,$newflg,$new_part,$newrecord) = @_;      my ($request,$symb,$stuname,$domain,$newflg,$new_part,$newrecord) = @_;
     my $portfolio_root = &propath($domain,$stuname).'/userfiles/portfolio';      my $portfolio_root = '/userfiles/portfolio';
     my ($partlist,$handgrade,$responseType) = &response_type($symb);      my ($partlist,$handgrade,$responseType) = &response_type($symb);
   
     my @part_response_id = &flatten_responseType($responseType);      my @part_response_id = &flatten_responseType($responseType);
Line 2785  sub handback_files { Line 2786  sub handback_files {
                     my ($answer_name,$answer_ver,$answer_ext) =                      my ($answer_name,$answer_ver,$answer_ext) =
         &file_name_version_ext($answer_file);          &file_name_version_ext($answer_file);
     my ($portfolio_path) = ($directory =~ /^.+$stuname\/portfolio(.*)/);      my ($portfolio_path) = ($directory =~ /^.+$stuname\/portfolio(.*)/);
     my @dir_list = &Apache::lonnet::dirlist($portfolio_path,$domain,$stuname,$portfolio_root);                      my $getpropath = 1;
       my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$portfolio_path,$domain,$stuname,$getpropath);
     my $version = &get_next_version($answer_name, $answer_ext, \@dir_list);      my $version = &get_next_version($answer_name, $answer_ext, \@dir_list);
                     # fix file name                      # fix file name
                     my ($save_file_name) = (($directory.$answer_name.".$version.".$answer_ext) =~ /^.+\/${stuname}\/(.*)/);                      my ($save_file_name) = (($directory.$answer_name.".$version.".$answer_ext) =~ /^.+\/${stuname}\/(.*)/);
Line 2921  sub version_portfiles { Line 2923  sub version_portfiles {
     my $version_parts = join('|',@$v_flag);      my $version_parts = join('|',@$v_flag);
     my @returned_keys;      my @returned_keys;
     my $parts = join('|', @$parts_graded);      my $parts = join('|', @$parts_graded);
     my $portfolio_root = &propath($domain,$stu_name).      my $portfolio_root = '/userfiles/portfolio';
  '/userfiles/portfolio';  
     foreach my $key (keys(%$record)) {      foreach my $key (keys(%$record)) {
         my $new_portfiles;          my $new_portfiles;
         if ($key =~ /^resource\.($version_parts)\./ && $key =~ /\.portfiles$/ ) {          if ($key =~ /^resource\.($version_parts)\./ && $key =~ /\.portfiles$/ ) {
Line 2933  sub version_portfiles { Line 2934  sub version_portfiles {
                 my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/);                  my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/);
  my ($answer_name,$answer_ver,$answer_ext) =   my ($answer_name,$answer_ver,$answer_ext) =
     &file_name_version_ext($answer_file);      &file_name_version_ext($answer_file);
                 my @dir_list = &Apache::lonnet::dirlist($directory,$domain,$stu_name,$portfolio_root);                  my $getpropath = 1;    
                   my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$directory,$domain,$stu_name,$getpropath);
                 my $version = &get_next_version($answer_name, $answer_ext, \@dir_list);                  my $version = &get_next_version($answer_name, $answer_ext, \@dir_list);
                 my $new_answer = &version_selected_portfile($domain, $stu_name, $directory, $answer_file, $version);                  my $new_answer = &version_selected_portfile($domain, $stu_name, $directory, $answer_file, $version);
                 if ($new_answer ne 'problem getting file') {                  if ($new_answer ne 'problem getting file') {
Line 4042  sub csvuploadassign { Line 4044  sub csvuploadassign {
  $grades{$store_key}=$entries{$fields{$dest}};   $grades{$store_key}=$entries{$fields{$dest}};
     }      }
  }   }
  if (! %grades) { push(@skipped,"$username:$domain no data to save"); }   if (! %grades) { 
  $grades{"resource.regrader"}="$env{'user.name'}:$env{'user.domain'}";             push(@skipped,&mt("[_1]: no data to save","$username:$domain")); 
  my $result=&Apache::lonnet::cstore(\%grades,$symb,          } else {
      $grades{"resource.regrader"}="$env{'user.name'}:$env{'user.domain'}";
      my $result=&Apache::lonnet::cstore(\%grades,$symb,
    $env{'request.course.id'},     $env{'request.course.id'},
    $domain,$username);     $domain,$username);
  if ($result eq 'ok') {     if ($result eq 'ok') {
     $request->print('.');        $request->print('.');
  } else {     } else {
     $request->print("<p>        $request->print("<p><span class=\"LC_error\">".
                               <span class=\"LC_error\">                                &mt("Failed to save data for student [_1]. Message when trying to save was: [_2]",
                                  Failed to save student $username:$domain.                                    "$username:$domain",$result)."</span></p>");
                                  Message when trying to save was ($result)     }
                               </span>     $request->rflush();
                              </p>" );     $countdone++;
  }          }
  $request->rflush();  
  $countdone++;  
     }      }
     $request->print("<br />Saved $countdone students\n");      $request->print('<br /><span class="LC_info">'.&mt("Saved [_1] students",$countdone)."</span>\n");
     if (@skipped) {      if (@skipped) {
  $request->print('<p><h4><b>Skipped Students</b></h4></p>');   $request->print('<p><span class="LC_warning">'.&mt('Skipped Students').'</span></p>');
  foreach my $student (@skipped) { $request->print("$student<br />\n"); }   foreach my $student (@skipped) { $request->print("$student<br />\n"); }
     }      }
     if (@notallowed) {      if (@notallowed) {
  $request->print('<p><span class="LC_error">Students Not Allowed to Modify</span></p>');   $request->print('<p><span class="LC_error">'.&mt('Students Not Allowed to Modify').'</span></p>');
  foreach my $student (@notallowed) { $request->print("$student<br />\n"); }   foreach my $student (@notallowed) { $request->print("$student<br />\n"); }
     }      }
     $request->print("<br />\n");      $request->print("<br />\n");
Line 4256  sub displayPage { Line 4258  sub displayPage {
     my $result='<h3><span class="LC_info">&nbsp;'.$env{'form.title'}.'</span></h3>';      my $result='<h3><span class="LC_info">&nbsp;'.$env{'form.title'}.'</span></h3>';
     $result.='<h3>&nbsp;'.&mt('Student: [_1]',&nameUserString(undef,$$fullname{$env{'form.student'}},$uname,$udom)).      $result.='<h3>&nbsp;'.&mt('Student: [_1]',&nameUserString(undef,$$fullname{$env{'form.student'}},$uname,$udom)).
  '</h3>'."\n";   '</h3>'."\n";
     if (&Apache::lonnet::validCODE($env{'form.CODE'})) {      $env{'form.CODE'} = uc($env{'form.CODE'});
       if (&Apache::lonnet::validCODE(uc($env{'form.CODE'}))) {
  $result.='<h3>&nbsp;'.&mt('CODE: [_1]',$env{'form.CODE'}).'</h3>'."\n";   $result.='<h3>&nbsp;'.&mt('CODE: [_1]',$env{'form.CODE'}).'</h3>'."\n";
     } else {      } else {
  delete($env{'form.CODE'});   delete($env{'form.CODE'});
Line 4757  sub getSequenceDropDown { Line 4760  sub getSequenceDropDown {
     return $result;      return $result;
 }  }
   
   my %bubble_lines_per_response;     # no. bubble lines for each response.
                                      # index is "symb.part_id"
   
   my %first_bubble_line;             # First bubble line no. for each bubble.
   
   my %subdivided_bubble_lines;       # no. bubble lines for optionresponse, 
                                      # matchresponse or rankresponse, where 
                                      # an individual response can have multiple 
                                      # lines
   
   my %responsetype_per_response;     # responsetype for each response
   
   # Save and restore the bubble lines array to the form env.
   
   
   sub save_bubble_lines {
       foreach my $line (keys(%bubble_lines_per_response)) {
    $env{"form.scantron.bubblelines.$line"}  = $bubble_lines_per_response{$line};
    $env{"form.scantron.first_bubble_line.$line"} =
       $first_bubble_line{$line};
           $env{"form.scantron.sub_bubblelines.$line"} = 
               $subdivided_bubble_lines{$line};
           $env{"form.scantron.responsetype.$line"} =
               $responsetype_per_response{$line};
       }
   }
   
   
   sub restore_bubble_lines {
       my $line = 0;
       %bubble_lines_per_response = ();
       while ($env{"form.scantron.bubblelines.$line"}) {
    my $value = $env{"form.scantron.bubblelines.$line"};
    $bubble_lines_per_response{$line} = $value;
    $first_bubble_line{$line}  =
       $env{"form.scantron.first_bubble_line.$line"};
           $subdivided_bubble_lines{$line} =
               $env{"form.scantron.sub_bubblelines.$line"};
           $responsetype_per_response{$line} =
               $env{"form.scantron.responsetype.$line"};
    $line++;
       }
   
   }
   
   #  Given the parsed scanline, get the response for 
   #  'answer' number n:
   
   sub get_response_bubbles {
       my ($parsed_line, $response)  = @_;
   
   
       my $bubble_line = $first_bubble_line{$response-1} +1;
       my $bubble_lines= $bubble_lines_per_response{$response-1};
       
       my $selected = "";
   
       for (my $bline = 0; $bline < $bubble_lines; $bline++) {
    $selected .= $$parsed_line{"scantron.$bubble_line.answer"}.":";
    $bubble_line++;
       }
       return $selected;
   }
   
 =pod   =pod 
   
Line 4769  sub getSequenceDropDown { Line 4835  sub getSequenceDropDown {
 sub scantron_filenames {  sub scantron_filenames {
     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};      my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
     my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};      my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};
       my $getpropath = 1;
     my @files=&Apache::lonnet::dirlist('userfiles',$cdom,$cname,      my @files=&Apache::lonnet::dirlist('userfiles',$cdom,$cname,
     &propath($cdom,$cname));                                         $getpropath);
     my @possiblenames;      my @possiblenames;
     foreach my $filename (sort(@files)) {      foreach my $filename (sort(@files)) {
  ($filename)=split(/&/,$filename);   ($filename)=split(/&/,$filename);
Line 4813  sub scantron_uploads { Line 4880  sub scantron_uploads {
 =cut  =cut
   
 sub scantron_scantab {  sub scantron_scantab {
     my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.'/scantronformat.tab');  
     my $result='<select name="scantron_format">'."\n";      my $result='<select name="scantron_format">'."\n";
     $result.='<option></option>'."\n";      $result.='<option></option>'."\n";
     foreach my $line (<$fh>) {      my @lines = &get_scantronformat_file();
  my ($name,$descrip)=split(/:/,$line);      if (@lines > 0) {
  if ($name =~ /^\#/) { next; }          foreach my $line (@lines) {
  $result.='<option value="'.$name.'">'.$descrip.'</option>'."\n";              next if (($line =~ /^\#/) || ($line eq ''));
       my ($name,$descrip)=split(/:/,$line);
       $result.='<option value="'.$name.'">'.$descrip.'</option>'."\n";
           }
     }      }
     $result.='</select>'."\n";      $result.='</select>'."\n";
   
     return $result;      return $result;
 }  }
   
   =pod
   
   =item get_scantronformat_file
   
     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    
   
   =cut
   
   sub get_scantronformat_file {
       my $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'};
       my %domconfig = &Apache::lonnet::get_dom('configuration',['scantron'],$cdom);
       my $gottab = 0;
       my @lines;
       if (ref($domconfig{'scantron'}) eq 'HASH') {
           if ($domconfig{'scantron'}{'scantronformat'} ne '') {
               my $formatfile = &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'});
               if ($formatfile ne '-1') {
                   @lines = split("\n",$formatfile,-1);
                   $gottab = 1;
               }
           }
       }
       if (!$gottab) {
           my $confname = $cdom.'-domainconfig';
           my $default = $Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab';
           my $formatfile =  &Apache::lonnet::getfile($default);
           if ($formatfile ne '-1') {
               @lines = split("\n",$formatfile,-1);
               $gottab = 1;
           }
       }
       if (!$gottab) {
           my @domains = &Apache::lonnet::current_machine_domains();
           if (grep(/^\Q$cdom\E$/,@domains)) {
               my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.'/scantronformat.tab');
               @lines = <$fh>;
               close($fh);
           } else {
               my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.'/default_scantronformat.tab');
               @lines = <$fh>;
               close($fh);
           }
       }
       return @lines;
   }
   
 =pod   =pod 
   
 =item scantron_CODElist  =item scantron_CODElist
Line 4899  sub scantron_selectphase { Line 5023  sub scantron_selectphase {
     my $CODE_unique=&scantron_CODEunique();      my $CODE_unique=&scantron_CODEunique();
     my $result;      my $result;
   
       $ssi_error = 0;
   
     # Chunk of form to prompt for a file to grade and how:      # Chunk of form to prompt for a file to grade and how:
   
     $result.= '      $result.= '
Line 5082  sub scantron_selectphase { Line 5208  sub scantron_selectphase {
   
 sub get_scantron_config {  sub get_scantron_config {
     my ($which) = @_;      my ($which) = @_;
     my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.'/scantronformat.tab');      my @lines = &get_scantronformat_file();
     my %config;      my %config;
     #FIXME probably should move to XML it has already gotten a bit much now      #FIXME probably should move to XML it has already gotten a bit much now
     foreach my $line (<$fh>) {      foreach my $line (@lines) {
  my ($name,$descrip)=split(/:/,$line);   my ($name,$descrip)=split(/:/,$line);
  if ($name ne $which ) { next; }   if ($name ne $which ) { next; }
  chomp($line);   chomp($line);
Line 5098  sub get_scantron_config { Line 5224  sub get_scantron_config {
  $config{'IDstart'}=$config[5];   $config{'IDstart'}=$config[5];
  $config{'IDlength'}=$config[6];   $config{'IDlength'}=$config[6];
  $config{'Qstart'}=$config[7];   $config{'Qstart'}=$config[7];
  $config{'Qlength'}=$config[8];    $config{'Qlength'}=$config[8];
  $config{'Qoff'}=$config[9];   $config{'Qoff'}=$config[9];
  $config{'Qon'}=$config[10];   $config{'Qon'}=$config[10];
  $config{'PaperID'}=$config[11];   $config{'PaperID'}=$config[11];
Line 5172  sub username_to_idmap { Line 5298  sub username_to_idmap {
                           - 'answer'                            - 'answer'
                                'response' - new answer or 'none' if blank                                 'response' - new answer or 'none' if blank
                                'question' - the bubble line to change                                 'question' - the bubble line to change
                                  'questionnum' - the question identifier,
                                                  may include subquestion. 
   
   Returns:    Returns:
     $line - the modified scanline      $line - the modified scanline
Line 5184  sub username_to_idmap { Line 5312  sub username_to_idmap {
   
 sub scantron_fixup_scanline {  sub scantron_fixup_scanline {
     my ($scantron_config,$scan_data,$line,$whichline,$field,$args)=@_;      my ($scantron_config,$scan_data,$line,$whichline,$field,$args)=@_;
       
       
     if ($field eq 'ID') {      if ($field eq 'ID') {
  if (length($args->{'newid'}) > $$scantron_config{'IDlength'}) {   if (length($args->{'newid'}) > $$scantron_config{'IDlength'}) {
     return ($line,1,'New value too large');      return ($line,1,'New value too large');
Line 5216  sub scantron_fixup_scanline { Line 5342  sub scantron_fixup_scanline {
    $$scantron_config{'CODElength'})=$args->{'CODE'};     $$scantron_config{'CODElength'})=$args->{'CODE'};
  }   }
     } elsif ($field eq 'answer') {      } elsif ($field eq 'answer') {
  &scantron_get_maxbubble(); # Need the bubble counter info.   my $length=$scantron_config->{'Qlength'};
  my $length =$scantron_config->{'Qlength'};  
  my $off=$scantron_config->{'Qoff'};   my $off=$scantron_config->{'Qoff'};
  my $on=$scantron_config->{'Qon'};   my $on=$scantron_config->{'Qon'};
         my $question_number = $args->{'question'} -1;   my $answer=${off}x$length;
         my $first_position  = $first_bubble_line{$question_number};   if ($args->{'response'} eq 'none') {
  my $bubble_count    = $bubble_lines_per_response{$question_number};      &scan_data($scan_data,
         my $bubbles_per_line= $$scantron_config{'Qlength'};         "$whichline.no_bubble.".$args->{'questionnum'},'1');
  my $answer=${off}x($bubbles_per_line*$bubble_count);   } else {
         my $final_answer;      if ($on eq 'letter') {
         if ($$scantron_config{'Qon'} eq 'letter'  ||   my @alphabet=('A'..'Z');
     $$scantron_config{'Qon'} eq 'number') {    $answer=$alphabet[$args->{'response'}];
     $bubbles_per_line = 10;      } elsif ($on eq 'number') {
  }   $answer=$args->{'response'}+1;
  if (defined $args->{'response'}) {   if ($answer == 10) { $answer = '0'; }
       
     if ($args->{'response'} eq 'none') {  
  &scan_data($scan_data,  
    "$whichline.no_bubble.".$args->{'question'},'1');  
     } else {      } else {
  my ($bubble_line, $bubble_number) = split(/:/,$args->{'response'});   substr($answer,$args->{'response'},1)=$on;
  if ($on eq 'letter') {  
     my @alphabet=('A'..'Z');  
     $answer=$alphabet[$bubble_number];  
  } elsif ($on eq 'number') {  
     $answer= $bubble_number+1;  
     if ($answer == 10) { $answer = '0'; }  
  } else {  
     substr($answer,$bubble_number+$bubble_line*$bubbles_per_line,1)=$on;  
     $final_answer = $answer;  
  }  
  &scan_data($scan_data,  
    "$whichline.no_bubble.".$args->{'question'},undef,'1');  
   
  # Positional notation already has the right final answer length..  
   
  if (($on eq 'letter') || ($on eq 'number')) {  
     for (my $l = 0; $l < $bubble_count; $l++) {  
  if ($l eq $bubble_line) {  
     $final_answer .= $answer;  
  } else {  
     $final_answer .= ' ';  
  }  
     }  
  }  
     }      }
     # $where=$length*($args->{'question'}-1)+$scantron_config->{'Qstart'};      &scan_data($scan_data,
     #substr($line,$where-1,$length)=$answer;         "$whichline.no_bubble.".$args->{'questionnum'},undef,'1');
     substr($line,   
    $scantron_config->{'Qstart'}+$first_position-1,  
    $bubbles_per_line*$length) = $final_answer;  
  }   }
    my $where=$length*($args->{'question'}-1)+$scantron_config->{'Qstart'};
    substr($line,$where-1,$length)=$answer;
     }      }
     return $line;      return $line;
 }  }
Line 5301  sub scan_data { Line 5397  sub scan_data {
     return $scan_data->{$filename.'_'.$key};      return $scan_data->{$filename.'_'.$key};
 }  }
   
   # ----- These first few routines are general use routines.----
   
   # Return the number of occurences of a pattern in a string.
   
   sub occurence_count {
       my ($string, $pattern) = @_;
   
       my @matches = ($string =~ /$pattern/g);
   
       return scalar(@matches);
   }
   
   
   # Take a string known to have digits and convert all the
   # digits into letters in the range J,A..I.
   
   sub digits_to_letters {
       my ($input) = @_;
   
       my @alphabet = ('J', 'A'..'I');
   
       my @input    = split(//, $input);
       my $output ='';
       for (my $i = 0; $i < scalar(@input); $i++) {
    if ($input[$i] =~ /\d/) {
       $output .= $alphabet[$input[$i]];
    } else {
       $output .= $input[$i];
    }
       }
       return $output;
   }
   
 =pod   =pod 
   
 =item scantron_parse_scanline  =item scantron_parse_scanline
Line 5403  sub scantron_parse_scanline { Line 5532  sub scantron_parse_scanline {
     $questions =~ s/\r$//;      # Get rid of trailing \r too (MAC or Win uploads).      $questions =~ s/\r$//;      # Get rid of trailing \r too (MAC or Win uploads).
     while (length($questions)) {      while (length($questions)) {
  my $answers_needed = $bubble_lines_per_response{$questnum};   my $answers_needed = $bubble_lines_per_response{$questnum};
  my $answer_length  = ($$scantron_config{'Qlength'} * $answers_needed)          my $answer_length  = ($$scantron_config{'Qlength'} * $answers_needed)
                      || 1;                               || 1;
           $questnum++;
  $questnum++;          my $quest_id = $questnum;
  my $currentquest = substr($questions,0,$answer_length);          my $currentquest = substr($questions,0,$answer_length);
  $questions       = substr($questions,$answer_length);          $questions       = substr($questions,$answer_length);
  if (length($currentquest) < $answer_length) { next; }          if (length($currentquest) < $answer_length) { next; }
   
  # Qon letter implies for each slot in currentquest we have:          if ($subdivided_bubble_lines{$questnum-1} =~ /,/) {
  #    ? or * for doubles a letter in A-Z for a bubble and              my $subquestnum = 1;
         #    about anything else (esp. a value of Qoff for missing              my $subquestions = $currentquest;
  #    bubbles.              my @subanswers_needed = 
                   split(/,/,$subdivided_bubble_lines{$questnum-1});  
               foreach my $subans (@subanswers_needed) {
  if ($$scantron_config{'Qon'} eq 'letter') {                  my $subans_length =
     if ($currentquest =~ /\?/                      ($$scantron_config{'Qlength'} * $subans)  || 1;
  || $currentquest =~ /\*/                  my $currsubquest = substr($subquestions,0,$subans_length);
  || (&occurence_count($currentquest, "[A-Z]") > 1)) {                  $subquestions   = substr($subquestions,$subans_length);
  push(@{$record{'scantron.doubleerror'}},$questnum);                  $quest_id = "$questnum.$subquestnum";
  for (my $ans = 0; $ans < $answers_needed; $ans++) {                   if (($$scantron_config{'Qon'} eq 'letter') ||
     my $bubble = substr($currentquest, $ans, 1);                      ($$scantron_config{'Qon'} eq 'number')) {
     if ($bubble =~ /[A-Z]/ ) {                      $ansnum = &scantron_validator_lettnum($ansnum, 
  $record{"scantron.$ansnum.answer"} = $bubble;                          $questnum,$quest_id,$subans,$currsubquest,$whichline,
     } else {                          \@alphabet,\%record,$scantron_config,$scan_data);
  $record{"scantron.$ansnum.answer"}='';                  } else {
     }                      $ansnum = &scantron_validator_positional($ansnum,
     $ansnum++;                          $questnum,$quest_id,$subans,$currsubquest,$whichline,                        \@alphabet,\%record,$scantron_config,$scan_data);
  }                  }
                   $subquestnum ++;
     } elsif (!defined($currentquest)              }
      || (&occurence_count($currentquest, $$scantron_config{'Qoff'}) == length($currentquest))          } else {
      || (&occurence_count($currentquest, "[A-Z]") == 0)) {              if (($$scantron_config{'Qon'} eq 'letter') ||
  for (my $ans = 0; $ans < $answers_needed; $ans++ ) {                  ($$scantron_config{'Qon'} eq 'number')) {
     $record{"scantron.$ansnum.answer"}='';                  $ansnum = &scantron_validator_lettnum($ansnum,$questnum,
     $ansnum++;                      $quest_id,$answers_needed,$currentquest,$whichline,
                       \@alphabet,\%record,$scantron_config,$scan_data);
  }              } else {
  if (!&scan_data($scan_data,"$whichline.no_bubble.$questnum")) {                  $ansnum = &scantron_validator_positional($ansnum,$questnum,
     push(@{$record{"scantron.missingerror"}},$questnum);                      $quest_id,$answers_needed,$currentquest,$whichline,
    #  $ansnum += $answers_needed;                      \@alphabet,\%record,$scantron_config,$scan_data);
  }              }
     } else {          }
  for (my $ans = 0; $ans < $answers_needed; $ans++) {      }
     my $bubble = substr($currentquest, $ans, 1);      $record{'scantron.maxquest'}=$questnum;
     $record{"scantron.$ansnum.answer"} = $bubble;      return \%record;
     $ansnum++;  }
  }  
     }  
   
  # Qon 'number' implies each slot gives a digit that indexes the  
  #    the bubbles filled or Qoff or a non number for unbubbled lines.  
         #    and *? for double bubbles on a line.  
  #    these answers are also stored as letters.  
   
  } elsif ($$scantron_config{'Qon'} eq 'number') {  
     if ($currentquest =~ /\?/  
  || $currentquest =~ /\*/  
  || (&occurence_count($currentquest, '\d') > 1)) {  
  push(@{$record{'scantron.doubleerror'}},$questnum);  
  for (my $ans = 0; $ans < $answers_needed; $ans++) {  
     my $bubble = substr($currentquest, $ans, 1);  
     if ($bubble =~ /\d/) {  
  $record{"scantron.$ansnum.answer"} = $alphabet[$bubble];  
     } else {  
  $record{"scantron.$ansnum.answer"}=' ';  
     }  
     $ansnum++;  
  }  
   
     } elsif (!defined($currentquest)  
      || (&occurence_count($currentquest,$$scantron_config{'Qoff'}) == length($currentquest))   
      || (&occurence_count($currentquest, '\d') == 0)) {  
  for (my $ans = 0; $ans < $answers_needed; $ans++ ) {  
     $record{"scantron.$ansnum.answer"}='';  
     $ansnum++;  
   
  }  
  if (!&scan_data($scan_data,"$whichline.no_bubble.$questnum")) {  
     push(@{$record{"scantron.missingerror"}},$questnum);  
     $ansnum += $answers_needed;  
  }  
   
     } else {  
  $currentquest = &digits_to_letters($currentquest);  
  for (my $ans =0; $ans < $answers_needed; $ans++) {  
     $record{"scantron.$ansnum.answer"} = substr($currentquest, $ans, 1);  
     $ansnum++;  
  }  
     }  
  } else {  
   
     # Otherwise there's a positional notation;  sub scantron_validator_lettnum {
     # each bubble line requires Qlength items, and there are filled in      my ($ansnum,$questnum,$quest_id,$answers_needed,$currquest,$whichline,
     # bubbles for each case where there 'Qon' characters.          $alphabet,$record,$scantron_config,$scan_data) = @_;
     #  
       # Qon 'letter' implies for each slot in currquest we have:
       #    ? or * for doubles, a letter in A-Z for a bubble, and
       #    about anything else (esp. a value of Qoff) for missing
       #    bubbles.
       #
       # Qon 'number' implies each slot gives a digit that indexes the
       #    bubbles filled, or Qoff, or a non-number for unbubbled lines,
       #    and * or ? for double bubbles on a single line.
       #
   
     my @array=split($$scantron_config{'Qon'},$currentquest,-1);      my $matchon;
       if ($$scantron_config{'Qon'} eq 'letter') {
           $matchon = '[A-Z]';
       } elsif ($$scantron_config{'Qon'} eq 'number') {
           $matchon = '\d';
       }
       my $occurrences = 0;
       if (($responsetype_per_response{$questnum-1} eq 'essayresponse') ||
           ($responsetype_per_response{$questnum-1} eq 'formularesponse') ||
           ($responsetype_per_response{$questnum-1} eq 'stringresponse') ||
           ($responsetype_per_response{$questnum-1} eq 'imageresponse') ||
           ($responsetype_per_response{$questnum-1} eq 'reactionresponse') ||
           ($responsetype_per_response{$questnum-1} eq 'organicresponse')) {
           my @singlelines = split('',$currquest);
           foreach my $entry (@singlelines) {
               $occurrences = &occurence_count($entry,$matchon);
               if ($occurrences > 1) {
                   last;
               }
           } 
       } else {
           $occurrences = &occurence_count($currquest,$matchon); 
       }
       if (($currquest =~ /\?/ || $currquest =~ /\*/) || ($occurrences > 1)) {
           push(@{$record->{'scantron.doubleerror'}},$quest_id);
           for (my $ans=0; $ans<$answers_needed; $ans++) {
               my $bubble = substr($currquest,$ans,1);
               if ($bubble =~ /$matchon/ ) {
                   if ($$scantron_config{'Qon'} eq 'number') {
                       if ($bubble == 0) {
                           $bubble = 10; 
                       }
                       $record->{"scantron.$ansnum.answer"} = 
                           $alphabet->[$bubble-1];
                   } else {
                       $record->{"scantron.$ansnum.answer"} = $bubble;
                   }
               } else {
                   $record->{"scantron.$ansnum.answer"}='';
               }
               $ansnum++;
           }
       } elsif (!defined($currquest)
               || (&occurence_count($currquest, $$scantron_config{'Qoff'}) == length($currquest))
               || (&occurence_count($currquest,$matchon) == 0)) {
           for (my $ans=0; $ans<$answers_needed; $ans++ ) {
               $record->{"scantron.$ansnum.answer"}='';
               $ansnum++;
           }
           if (!&scan_data($scan_data,"$whichline.no_bubble.$quest_id")) {
               push(@{$record->{'scantron.missingerror'}},$quest_id);
           }
       } else {
           if ($$scantron_config{'Qon'} eq 'number') {
               $currquest = &digits_to_letters($currquest);            
           }
           for (my $ans=0; $ans<$answers_needed; $ans++) {
               my $bubble = substr($currquest,$ans,1);
               $record->{"scantron.$ansnum.answer"} = $bubble;
               $ansnum++;
           }
       }
       return $ansnum;
   }
   
     # If the split only  giveas us one element.. the full length of the  sub scantron_validator_positional {
     # answser string, no bubbles are filled in:      my ($ansnum,$questnum,$quest_id,$answers_needed,$currquest,
           $whichline,$alphabet,$record,$scantron_config,$scan_data) = @_;
   
     if (length($array[0]) eq $$scantron_config{'Qlength'}*$answers_needed) {      # Otherwise there's a positional notation;
  for (my $ans = 0; $ans < $answers_needed; $ans++ ) {      # each bubble line requires Qlength items, and there are filled in
     $record{"scantron.$ansnum.answer"}='';      # bubbles for each case where there 'Qon' characters.
     $ansnum++;      #
   
  }      my @array=split($$scantron_config{'Qon'},$currquest,-1);
  if (!&scan_data($scan_data,"$whichline.no_bubble.$questnum")) {  
     push(@{$record{"scantron.missingerror"}},$questnum);  
  }  
   
   
       # If the split only gives us one element.. the full length of the
       # answer string, no bubbles are filled in:
   
     } elsif (scalar(@array) eq 2) {      if ($answers_needed eq '') {
           return;
       }
   
  my $location      = length($array[0]);      if (length($array[0]) eq $$scantron_config{'Qlength'}*$answers_needed) {
  my $line_num      = int($location / $$scantron_config{'Qlength'});          for (my $ans=0; $ans<$answers_needed; $ans++ ) {
  my $bubble        = $alphabet[$location % $$scantron_config{'Qlength'}];              $record->{"scantron.$ansnum.answer"}='';
               $ansnum++;
           }
           if (!&scan_data($scan_data,"$whichline.no_bubble.$quest_id")) {
               push(@{$record->{"scantron.missingerror"}},$quest_id);
           }
       } elsif (scalar(@array) == 2) {
           my $location = length($array[0]);
           my $line_num = int($location / $$scantron_config{'Qlength'});
           my $bubble   = $alphabet->[$location % $$scantron_config{'Qlength'}];
           for (my $ans=0; $ans<$answers_needed; $ans++) {
               if ($ans eq $line_num) {
                   $record->{"scantron.$ansnum.answer"} = $bubble;
               } else {
                   $record->{"scantron.$ansnum.answer"} = ' ';
               }
               $ansnum++;
            }
       } else {
           #  If there's more than one instance of a bubble character
           #  That's a double bubble; with positional notation we can
           #  record all the bubbles filled in as well as the
           #  fact this response consists of multiple bubbles.
           #
           if (($responsetype_per_response{$questnum-1} eq 'essayresponse') ||
               ($responsetype_per_response{$questnum-1} eq 'formularesponse') ||
               ($responsetype_per_response{$questnum-1} eq 'stringresponse') ||
               ($responsetype_per_response{$questnum-1} eq 'imageresponse') ||
               ($responsetype_per_response{$questnum-1} eq 'reactionresponse') ||
               ($responsetype_per_response{$questnum-1} eq 'organicresponse')) {
               my $doubleerror = 0;
               while (($currquest >= $$scantron_config{'Qlength'}) && 
                      (!$doubleerror)) {
                  my $currline = substr($currquest,0,$$scantron_config{'Qlength'});
                  $currquest = substr($currquest,$$scantron_config{'Qlength'});
                  my @currarray = split($$scantron_config{'Qon'},$currline,-1);
                  if (length(@currarray) > 2) {
                      $doubleerror = 1;
                  } 
               }
               if ($doubleerror) {
                   push(@{$record->{'scantron.doubleerror'}},$quest_id);
               }
           } else {
               push(@{$record->{'scantron.doubleerror'}},$quest_id);
           }
           my $item = $ansnum;
           for (my $ans=0; $ans<$answers_needed; $ans++) {
               $record->{"scantron.$item.answer"} = '';
               $item ++;
           }
   
  for (my $ans = 0; $ans < $answers_needed; $ans++) {          my @ans=@array;
     if ($ans eq $line_num) {          my $i=0;
  $record{"scantron.$ansnum.answer"} = $bubble;          my $increment = 0;
     } else {          while ($#ans) {
  $record{"scantron.$ansnum.answer"} = ' ';              $i+=length($ans[0]) + $increment;
     }              my $line   = int($i/$$scantron_config{'Qlength'} + $ansnum);
     $ansnum++;              my $bubble = $i%$$scantron_config{'Qlength'};
  }              $record->{"scantron.$line.answer"}.=$alphabet->[$bubble];
     }              shift(@ans);
     #  If there's more than one instance of a bubble character              $increment = 1;
     #  That's a double bubble; with positional notation we can          }
     #  record all the bubbles filled in as well as the           $ansnum += $answers_needed;
     #  fact this response consists of multiple bubbles.  
     #  
     else {  
  push(@{$record{'scantron.doubleerror'}},$questnum);  
   
  my $first_answer = $ansnum;  
  for (my $ans =0; $ans < $answers_needed; $ans++) {  
     my $item = $first_answer+$ans;  
     $record{"scantron.$item.answer"} = '';  
  }  
   
  my @ans=@array;  
  my $i=0;  
  my $increment = 0;  
  while ($#ans) {  
     $i+=length($ans[0]) + $increment;  
     my $line   = int($i/$$scantron_config{'Qlength'} + $first_answer);  
     my $bubble = $i%$$scantron_config{'Qlength'};  
     $record{"scantron.$line.answer"}.=$alphabet[$bubble];  
     shift(@ans);  
     $increment = 1;  
  }  
  $ansnum += $answers_needed;  
     }  
  }  
     }      }
     $record{'scantron.maxquest'}=$questnum;      return $ansnum;
     return \%record;  
 }  }
   
 =pod  =pod
Line 5702  sub scantron_process_corrections { Line 5883  sub scantron_process_corrections {
  &scantron_fixup_scanline(\%scantron_config,$scan_data,$line,   &scantron_fixup_scanline(\%scantron_config,$scan_data,$line,
  $which,'answer',   $which,'answer',
  { 'question'=>$question,   { 'question'=>$question,
        'response'=>$env{"form.scantron_correct_Q_$question"}});           'response'=>$env{"form.scantron_correct_Q_$question"},
                                      'questionnum'=>$env{"form.scantron_questionnum_Q_$question"}});
     if ($err) { last; }      if ($err) { last; }
  }   }
     }      }
Line 5921  SCANTRONFORM Line 6103  SCANTRONFORM
    '<input type="hidden" name="scantron.bubblelines.'.$line.'" value="'.$env{"form.scantron.bubblelines.$line"}.'" />'."\n";     '<input type="hidden" name="scantron.bubblelines.'.$line.'" value="'.$env{"form.scantron.bubblelines.$line"}.'" />'."\n";
        $chunk .=         $chunk .=
    '<input type="hidden" name="scantron.first_bubble_line.'.$line.'" value="'.$env{"form.scantron.first_bubble_line.$line"}.'" />'."\n";     '<input type="hidden" name="scantron.first_bubble_line.'.$line.'" value="'.$env{"form.scantron.first_bubble_line.$line"}.'" />'."\n";
          $chunk .= 
              '<input type="hidden" name="scantron.sub_bubblelines.'.$line.'" value="'.$env{"form.scantron.sub_bubblelines.$line"}.'" />'."\n";
          $chunk .=
              '<input type="hidden" name="scantron.responsetype.'.$line.'" value="'.$env{"form.scantron.responsetype.$line"}.'" />'."\n";
        $result .= $chunk;         $result .= $chunk;
        $line++;         $line++;
    }     }
Line 5965  sub scantron_validate_file { Line 6151  sub scantron_validate_file {
     if ($env{'form.scantron_corrections'}) {      if ($env{'form.scantron_corrections'}) {
  &scantron_process_corrections($r);   &scantron_process_corrections($r);
     }      }
     $r->print('<p>'.&mt('Gathering necessary info.').'</p>');$r->rflush();      $r->print('<p>'.&mt('Gathering necessary information.').'</p>');$r->rflush();
     #get the student pick code ready      #get the student pick code ready
     $r->print(&Apache::loncommon::studentbrowser_javascript());      $r->print(&Apache::loncommon::studentbrowser_javascript());
     my $max_bubble=&scantron_get_maxbubble();      my $max_bubble=&scantron_get_maxbubble();
Line 5985  sub scantron_validate_file { Line 6171  sub scantron_validate_file {
   
     my $stop=0;      my $stop=0;
     while (!$stop && $currentphase < scalar(@validate_phases)) {      while (!$stop && $currentphase < scalar(@validate_phases)) {
  $r->print('<p> '.&mt('Validating '.$validate_phases[$currentphase]).'</p>');   $r->print(&mt('Validating '.$validate_phases[$currentphase]).'<br />');
  $r->rflush();   $r->rflush();
  my $which="scantron_validate_".$validate_phases[$currentphase];   my $which="scantron_validate_".$validate_phases[$currentphase];
  {   {
Line 5995  sub scantron_validate_file { Line 6181  sub scantron_validate_file {
     }      }
     if (!$stop) {      if (!$stop) {
  my $warning=&scantron_warning_screen('Start Grading');   my $warning=&scantron_warning_screen('Start Grading');
  $r->print('   $r->print(&mt('Validation process complete.').'<br />
 '.&mt('Validation process complete.').'<br />  
 '.$warning.'  '.$warning.'
 <input type="submit" name="submit" value="'.&mt('Start Grading').'" />  <input type="submit" name="submit" value="'.&mt('Start Grading').'" />
 <input type="hidden" name="command" value="scantron_process" />  <input type="hidden" name="command" value="scantron_process" />
Line 6013  sub scantron_validate_file { Line 6198  sub scantron_validate_file {
   
     $r->print(" <p>".&mt("Or click the 'Grading Menu' button to start over.")."</p>");      $r->print(" <p>".&mt("Or click the 'Grading Menu' button to start over.")."</p>");
  } else {   } else {
     $r->print('<input type="submit" name="submit" value="'.&mt('Continue -&gt;').'" />');              if ($validate_phases[$currentphase] eq 'doublebubble' || $validate_phases[$currentphase] eq 'missingbubbles') {
           $r->print('<input type="button" name="submitbutton" value="'.&mt('Continue -&gt;').'" onclick="javascript:verify_bubble_radio(this.form)" />');
               } else {
                   $r->print('<input type="submit" name="submit" value="'.&mt('Continue -&gt;').'" />');
               }
     $r->print(' '.&mt('using corrected info').' <br />');      $r->print(' '.&mt('using corrected info').' <br />');
     $r->print("<input type='submit' value='".&mt("Skip")."' name='scantron_skip_record' />");      $r->print("<input type='submit' value='".&mt("Skip")."' name='scantron_skip_record' />");
     $r->print(" ".&mt("this scanline saving it for later."));      $r->print(" ".&mt("this scanline saving it for later."));
Line 6495  sub scantron_validate_ID { Line 6684  sub scantron_validate_ID {
   
 sub scantron_get_correction {  sub scantron_get_correction {
     my ($r,$i,$scan_record,$scan_config,$line,$error,$arg)=@_;      my ($r,$i,$scan_record,$scan_config,$line,$error,$arg)=@_;
   
 #FIXME in the case of a duplicated ID the previous line, probably need  #FIXME in the case of a duplicated ID the previous line, probably need
 #to show both the current line and the previous one and allow skipping  #to show both the current line and the previous one and allow skipping
 #the previous one or the current one  #the previous one or the current one
Line 6517  sub scantron_get_correction { Line 6705  sub scantron_get_correction {
   
     $r->print('<input type="hidden" name="scantron_corrections" value="'.$error.'" />'."\n");      $r->print('<input type="hidden" name="scantron_corrections" value="'.$error.'" />'."\n");
     $r->print('<input type="hidden" name="scantron_line" value="'.$i.'" />'."\n");      $r->print('<input type="hidden" name="scantron_line" value="'.$i.'" />'."\n");
                              # Array populated for doublebubble or
       my @lines_to_correct;  # missingbubble errors to build javascript
                              # to validate radio button checking   
   
     if ($error =~ /ID$/) {      if ($error =~ /ID$/) {
  if ($error eq 'incorrectID') {   if ($error eq 'incorrectID') {
     $r->print("<p>".&mt("The encoded ID is not in the classlist").      $r->print("<p>".&mt("The encoded ID is not in the classlist").
Line 6612  ENDSCRIPT Line 6804  ENDSCRIPT
      "</label><input type='text' size='8' name='scantron_CODE_newvalue' onfocus=\"javascript:change_radio('use_typed')\" onkeypress=\"javascript:change_radio('use_typed')\" />"));       "</label><input type='text' size='8' name='scantron_CODE_newvalue' onfocus=\"javascript:change_radio('use_typed')\" onkeypress=\"javascript:change_radio('use_typed')\" />"));
  $r->print("\n<br /><br />");   $r->print("\n<br /><br />");
     } elsif ($error eq 'doublebubble') {      } elsif ($error eq 'doublebubble') {
  $r->print("<p>".&mt("There have been multiple bubbles scanned for a some question(s)")."</p>\n");   $r->print("<p>".&mt("There have been multiple bubbles scanned for some question(s)")."</p>\n");
   
    # The form field scantron_questions is acutally a list of line numbers.
    # represented by this form so:
   
    my $line_list = &questions_to_line_list($arg);
   
  $r->print('<input type="hidden" name="scantron_questions" value="'.   $r->print('<input type="hidden" name="scantron_questions" value="'.
   join(',',@{$arg}).'" />');    $line_list.'" />');
  $r->print($message);   $r->print($message);
  $r->print("<p>".&mt("Please indicate which bubble should be used for grading")."</p>");   $r->print("<p>".&mt("Please indicate which bubble should be used for grading")."</p>");
  foreach my $question (@{$arg}) {   foreach my $question (@{$arg}) {
     my $selected  = &get_response_bubbles($scan_record, $question);      my @linenums = &prompt_for_corrections($r,$question,$scan_config,
     my @select_array = split(/:/,$selected);                                                     $scan_record, $error);
     &scantron_bubble_selector($r,$scan_config,$question,              push (@lines_to_correct,@linenums);
       @select_array);  
  }   }
           $r->print(&verify_bubbles_checked(@lines_to_correct));
     } elsif ($error eq 'missingbubble') {      } elsif ($error eq 'missingbubble') {
  $r->print("<p>".&mt("There have been <b>no</b> bubbles scanned for some question(s)")."</p>\n");   $r->print("<p>".&mt("There have been <b>no</b> bubbles scanned for some question(s)")."</p>\n");
  $r->print($message);   $r->print($message);
  $r->print("<p>".&mt("Please indicate which bubble should be used for grading.")."</p>");   $r->print("<p>".&mt("Please indicate which bubble should be used for grading.")."</p>");
  $r->print(&mt("Some questions have no scanned bubbles")."\n");   $r->print(&mt("Some questions have no scanned bubbles.")."\n");
   
    # The form field scantron_questions is actually a list of line numbers not
    # a list of question numbers. Therefore:
    #
   
    my $line_list = &questions_to_line_list($arg);
   
  $r->print('<input type="hidden" name="scantron_questions" value="'.   $r->print('<input type="hidden" name="scantron_questions" value="'.
   join(',',@{$arg}).'" />');    $line_list.'" />');
  foreach my $question (@{$arg}) {   foreach my $question (@{$arg}) {
     my $selected = &get_response_bubbles($scan_record, $question);      my @linenums = &prompt_for_corrections($r,$question,$scan_config,
     my @select_array = split(/:/,$selected); # ought to be an array of empties.                                                     $scan_record, $error);
     &scantron_bubble_selector($r,$scan_config,$question, @select_array);              push (@lines_to_correct,@linenums);
  }   }
           $r->print(&verify_bubbles_checked(@lines_to_correct));
     } else {      } else {
  $r->print("\n<ul>");   $r->print("\n<ul>");
     }      }
     $r->print("\n</li></ul>");      $r->print("\n</li></ul>");
   }
   
   sub verify_bubbles_checked {
       my (@ansnums) = @_;
       my $ansnumstr = join('","',@ansnums);
       my $warning = &mt("A bubble or 'No bubble' selection has not been made for one or more lines.");
       my $output = (<<ENDSCRIPT);
   <script type="text/javascript">
   function verify_bubble_radio(form) {
       var ansnumArray = new Array ("$ansnumstr");
       var need_bubble_count = 0;
       for (var i=0; i<ansnumArray.length; i++) {
           if (form.elements["scantron_correct_Q_"+ansnumArray[i]].length > 1) {
               var bubble_picked = 0; 
               for (var j=0; j<form.elements["scantron_correct_Q_"+ansnumArray[i]].length; j++) {
                   if (form.elements["scantron_correct_Q_"+ansnumArray[i]][j].checked == true) {
                       bubble_picked = 1;
                   }
               }
               if (bubble_picked == 0) {
                   need_bubble_count ++;
               }
           }
       }
       if (need_bubble_count) {
           alert("$warning");
           return;
       }
       form.submit(); 
   }
   </script>
   ENDSCRIPT
       return $output;
   }
   
   =pod
   
   =item  questions_to_line_list
   
   Converts a list of questions into a string of comma separated
   line numbers in the answer sheet used by the questions.  This is
   used to fill in the scantron_questions form field.
   
     Arguments:
        questions    - Reference to an array of questions.
   
   =cut
   
   
   sub questions_to_line_list {
       my ($questions) = @_;
       my @lines;
   
       foreach my $item (@{$questions}) {
           my $question = $item;
           my ($first,$count,$last);
           if ($item =~ /^(\d+)\.(\d+)$/) {
               $question = $1;
               my $subquestion = $2;
               $first = $first_bubble_line{$question-1} + 1;
               my @subans = split(/,/,$subdivided_bubble_lines{$question-1});
               my $subcount = 1;
               while ($subcount<$subquestion) {
                   $first += $subans[$subcount-1];
                   $subcount ++;
               }
               $count = $subans[$subquestion-1];
           } else {
       $first   = $first_bubble_line{$question-1} + 1;
       $count   = $bubble_lines_per_response{$question-1};
           }
           $last = $first+$count-1;
           push(@lines, ($first..$last));
       }
       return join(',', @lines);
   }
   
   =pod 
   
   =item prompt_for_corrections
   
   Prompts for a potentially multiline correction to the
   user's bubbling (factors out common code from scantron_get_correction
   for multi and missing bubble cases).
   
    Arguments:
      $r           - Apache request object.
      $question    - The question number to prompt for.
      $scan_config - The scantron file configuration hash.
      $scan_record - Reference to the hash that has the the parsed scanlines.
      $error       - Type of error
   
    Implicit inputs:
      %bubble_lines_per_response   - Starting line numbers for each question.
                                     Numbered from 0 (but question numbers are from
                                     1.
      %first_bubble_line           - Starting bubble line for each question.
      %subdivided_bubble_lines     - optionresponse, matchresponse and rankresponse 
                                     type problems render as separate sub-questions, 
                                     in exam mode. This hash contains a 
                                     comma-separated list of the lines per 
                                     sub-question.
      %responsetype_per_response   - essayresponse, formularesponse,
                                     stringresponse, imageresponse, reactionresponse,
                                     and organicresponse type problem parts can have
                                     multiple lines per response if the weight
                                     assigned exceeds 10.  In this case, only
                                     one bubble per line is permitted, but more 
                                     than one line might contain bubbles, e.g.
                                     bubbling of: line 1 - J, line 2 - J, 
                                     line 3 - B would assign 22 points.  
   
   =cut
   
   sub prompt_for_corrections {
       my ($r, $question, $scan_config, $scan_record, $error) = @_;
       my ($current_line,$lines);
       my @linenums;
       my $questionnum = $question;
       if ($question =~ /^(\d+)\.(\d+)$/) {
           $question = $1;
           $current_line = $first_bubble_line{$question-1} + 1 ;
           my $subquestion = $2;
           my @subans = split(/,/,$subdivided_bubble_lines{$question-1});
           my $subcount = 1;
           while ($subcount<$subquestion) {
               $current_line += $subans[$subcount-1];
               $subcount ++;
           }
           $lines = $subans[$subquestion-1];
       } else {
           $current_line = $first_bubble_line{$question-1} + 1 ;
           $lines        = $bubble_lines_per_response{$question-1};
       }
       if ($lines > 1) {
           $r->print(&mt('The group of bubble lines below responds to a single question.').'<br />');
           if (($responsetype_per_response{$question-1} eq 'essayresponse') ||
               ($responsetype_per_response{$question-1} eq 'formularesponse') ||
               ($responsetype_per_response{$question-1} eq 'stringresponse') ||
               ($responsetype_per_response{$question-1} eq 'imageresponse') ||
               ($responsetype_per_response{$question-1} eq 'reactionresponse') ||
               ($responsetype_per_response{$question-1} eq 'organicresponse')) {
               $r->print(&mt("Although this particular question type requires handgrading, the instructions for this question in the exam directed students to leave [quant,_1,line] blank on their scantron sheets.",$lines).'<br /><br />'.&mt('A non-zero score can be assigned to the student during scantron grading by selecting a bubble in at least one line.').'<br />'.&mt('The score for this question will be a sum of the numeric values for the selected bubbles from each line, where A=1 point, B=2 points etc.').'<br />'.&mt("To assign a score of zero for this question, mark all lines as 'No bubble'.").'<br /><br />');
           } else {
               $r->print(&mt("Select at most one bubble in a single line and select 'No Bubble' in all the other lines. ")."<br />");
           }
       }
       for (my $i =0; $i < $lines; $i++) {
           my $selected = $$scan_record{"scantron.$current_line.answer"};
    &scantron_bubble_selector($r,$scan_config,$current_line, 
             $questionnum,$error,split('', $selected));
           push (@linenums,$current_line);
    $current_line++;
       }
       if ($lines > 1) {
    $r->print("<hr /><br />");
       }
       return @linenums;
 }  }
   
 =pod  =pod
Line 6652  ENDSCRIPT Line 7015  ENDSCRIPT
  Arguments:   Arguments:
     $r           - Apache request object      $r           - Apache request object
     $scan_config - hash from &get_scantron_config()      $scan_config - hash from &get_scantron_config()
     $quest       - number of the bubble line to make a corrector for      $line        - Number of the line being displayed.
     @lines       - array of answer lines.      $questionnum - Question number (may include subquestion)
       $error       - Type of error.
       @selected    - Array of bubbles picked on this line.
   
 =cut  =cut
   
 sub scantron_bubble_selector {  sub scantron_bubble_selector {
     my ($r,$scan_config,$quest,@lines)=@_;      my ($r,$scan_config,$line,$questionnum,$error,@selected)=@_;
     my $max=$$scan_config{'Qlength'};      my $max=$$scan_config{'Qlength'};
   
   
     my $scmode=$$scan_config{'Qon'};      my $scmode=$$scan_config{'Qon'};
   
     my $bubble_length = scalar(@lines);  
   
   
     if ($scmode eq 'number' || $scmode eq 'letter') { $max=10; }           if ($scmode eq 'number' || $scmode eq 'letter') { $max=10; }     
   
     my $response = $quest-1;  
     my $lines = $bubble_lines_per_response{$response};  
   
     my $total_lines = $lines*2;  
     my @alphabet=('A'..'Z');      my @alphabet=('A'..'Z');
       $r->print(&Apache::loncommon::start_data_table().
     $r->print("<table border='1'><tr><td rowspan='".$total_lines."'>$quest</td>");                &Apache::loncommon::start_data_table_row());
       $r->print('<td rowspan="2" class="LC_leftcol_header">'.$line.'</td>');
     for (my $l = 0; $l < $lines; $l++) {      for (my $i=0;$i<$max+1;$i++) {
  if ($l != 0) {   $r->print("\n".'<td align="center">');
     $r->print('<tr>');   if ($selected[0] eq $alphabet[$i]) { $r->print('X'); shift(@selected) }
  }   else { $r->print('&nbsp;'); }
  my @selected = split(//,$lines[$l]);   $r->print('</td>');
  for (my $i=0;$i<$max;$i++) {      }
     $r->print("\n".'<td align="center">');      $r->print(&Apache::loncommon::end_data_table_row().
     if ($selected[0] eq $alphabet[$i]) {                 &Apache::loncommon::start_data_table_row());
  $r->print('X');       for (my $i=0;$i<$max;$i++) {
  shift(@selected) ;   $r->print("\n".
     } else {     '<td><label><input type="radio" name="scantron_correct_Q_'.
  $r->print('&nbsp;');     $line.'" value="'.$i.'" />'.$alphabet[$i]."</label></td>");
     }      }
     $r->print('</td>');      my $nobub_checked = ' ';
           if ($error eq 'missingbubble') {
  }          $nobub_checked = ' checked = "checked" ';
       }
  if ($l == 0) {      $r->print("\n".'<td><label><input type="radio" name="scantron_correct_Q_'.
     my $lspan = $total_lines * 2;   #  2 table rows per bubble line.        $line.'" value="none"'.$nobub_checked.'/>'.&mt('No bubble').
                 '</label>'."\n".'<input type="hidden" name="scantron_questionnum_Q_'.
     $r->print('<td rowspan='.$lspan.'><label><input type="radio" name="scantron_correct_Q_'.                $line.'" value="'.$questionnum.'" /></td>');
       $quest.'" value="none" /> '.&mt('No bubble').' </label></td>');      $r->print(&Apache::loncommon::end_data_table_row().
                 &Apache::loncommon::end_data_table());
  }  
   
  $r->print('</tr><tr>');  
   
  # FIXME: This may have to be a bit more clever for  
  #        multiline questions (different values e.g..).  
   
  for (my $i=0;$i<$max;$i++) {  
     my $value = "$l:$i"; # Relative bubble line #: Bubble in line.  
     $r->print("\n".  
       '<td><label><input type="radio" name="scantron_correct_Q_'.  
       $quest.'" value="'.$value.'" />'.$alphabet[$i]."</label></td>");  
  }  
  $r->print('</tr>');  
   
       
     }  
     $r->print('</table>');  
 }  }
   
 =pod  =pod
Line 6897  sub scantron_validate_doublebubble { Line 7235  sub scantron_validate_doublebubble {
     #get scantron line setup      #get scantron line setup
     my %scantron_config=&get_scantron_config($env{'form.scantron_format'});      my %scantron_config=&get_scantron_config($env{'form.scantron_format'});
     my ($scanlines,$scan_data)=&scantron_getfile();      my ($scanlines,$scan_data)=&scantron_getfile();
   
     &scantron_get_maxbubble(); # parse needs the bubble line array.      &scantron_get_maxbubble(); # parse needs the bubble line array.
   
     for (my $i=0;$i<=$scanlines->{'count'};$i++) {      for (my $i=0;$i<=$scanlines->{'count'};$i++) {
Line 6924  sub scantron_validate_doublebubble { Line 7261  sub scantron_validate_doublebubble {
    for what the current value of the problem counter is.     for what the current value of the problem counter is.
   
    Caches the results to $env{'form.scantron_maxbubble'},     Caches the results to $env{'form.scantron_maxbubble'},
    $env{'form.scantron.bubble_lines.n'} and      $env{'form.scantron.bubble_lines.n'}, 
    $env{'form.scantron.first_bubble_line.n'}     $env{'form.scantron.first_bubble_line.n'} and
      $env{"form.scantron.sub_bubblelines.n"}
    which are the total number of bubble, lines, the number of bubble     which are the total number of bubble, lines, the number of bubble
    lines for reponse n and number of the first bubble line for response n.     lines for response n and number of the first bubble line for response n,
      and a comma separated list of numbers of bubble lines for sub-questions
      (for optionresponse, matchresponse, and rankresponse items), for response n.  
   
 =cut  =cut
   
 sub scantron_get_maxbubble {      sub scantron_get_maxbubble {
     if (defined($env{'form.scantron_maxbubble'}) &&      if (defined($env{'form.scantron_maxbubble'}) &&
  $env{'form.scantron_maxbubble'}) {   $env{'form.scantron_maxbubble'}) {
  &restore_bubble_lines();   &restore_bubble_lines();
Line 6953  sub scantron_get_maxbubble { Line 7293  sub scantron_get_maxbubble {
     my $total_lines = 0;      my $total_lines = 0;
     %bubble_lines_per_response = ();      %bubble_lines_per_response = ();
     %first_bubble_line         = ();      %first_bubble_line         = ();
       %subdivided_bubble_lines   = ();
       %responsetype_per_response = ();
       
     my $response_number = 0;      my $response_number = 0;
     my $bubble_line     = 0;      my $bubble_line     = 0;
     foreach my $resource (@resources) {      foreach my $resource (@resources) {
  my $symb = $resource->symb();          my $symb = $resource->symb();
  my $result=&Apache::lonnet::ssi($resource->src(),          # Need to retrieve part IDs and response IDs because essayresponse,
  ('symb' => $resource->symb()),          # reactionresponse and organicresponse items are not included in 
  ('grade_target' => 'analyze'),          # $analysis{'parts'} from lonnet::ssi.  
  ('grade_courseid' => $cid),          my %possible_part_ids; 
  ('grade_domain' => $udom),          if (ref($resource->parts()) eq 'ARRAY') { 
  ('grade_username' => $uname));              foreach my $part (@{$resource->parts()}) {
                   if (!&Apache::loncommon::check_if_partid_hidden($part,$symb,$udom,$uname)) {
                       my @resp_ids = $resource->responseIds($part);
                       foreach my $id (@resp_ids) {
                           $possible_part_ids{$part.'.'.$id} = 1;
                       }
                   }
               }
           }
    my $result=&ssi_with_retries($resource->src(), $ssi_retries,
    ('symb' => $symb,
    'grade_target' => 'analyze',
    'grade_courseid' => $cid,
    'grade_domain' => $udom,
    'grade_username' => $uname));
  my (undef, $an) =   my (undef, $an) =
     split(/_HASH_REF__/,$result, 2);      split(/_HASH_REF__/,$result, 2);
   
  my %analysis = &Apache::lonnet::str2hash($an);          my @parts;
   
   
    my %analysis = &Apache::lonnet::str2hash($an);
   
  foreach my $part_id (@{$analysis{'parts'}}) {          if (ref($analysis{'parts'}) eq 'ARRAY') {
               foreach my $part (@{$analysis{'parts'}}) {
     my $lines = $analysis{"$part_id.bubble_lines"};;                  my ($id,$respid) = split(/\./,$part);
                   if (!&Apache::loncommon::check_if_partid_hidden($id,$symb,$udom,$uname)) {
                       push(@parts,$part);
                   }
               }
           }
           # Add part_ids for any essayresponse items. 
           foreach my $part_id (keys(%possible_part_ids)) {
               if (($analysis{$part_id.'.type'} eq 'essayresponse') ||
                   ($analysis{$part_id.'.type'} eq 'reactionresponse') ||
                   ($analysis{$part_id.'.type'} eq 'organicresponse')) {
                   if (!grep(/^\Q$part_id\E$/,@parts)) {
                       push (@parts,$part_id);
                   }
               }
           }
   
    foreach my $part_id (@parts) {
               my $lines = $analysis{"$part_id.bubble_lines"};
   
     # TODO - make this a persistent hash not an array.      # TODO - make this a persistent hash not an array.
   
               # optionresponse, matchresponse and rankresponse type items 
               # render as separate sub-questions in exam mode.
               if (($analysis{$part_id.'.type'} eq 'optionresponse') ||
                   ($analysis{$part_id.'.type'} eq 'matchresponse') ||
                   ($analysis{$part_id.'.type'} eq 'rankresponse')) {
                   my ($numbub,$numshown);
                   if ($analysis{$part_id.'.type'} eq 'optionresponse') {
                       if (ref($analysis{$part_id.'.options'}) eq 'ARRAY') {
                           $numbub = scalar(@{$analysis{$part_id.'.options'}});
                       }
                   } elsif ($analysis{$part_id.'.type'} eq 'matchresponse') {
                       if (ref($analysis{$part_id.'.items'}) eq 'ARRAY') {
                           $numbub = scalar(@{$analysis{$part_id.'.items'}});
                       }
                   } elsif ($analysis{$part_id.'.type'} eq 'rankresponse') {
                       if (ref($analysis{$part_id.'.foils'}) eq 'ARRAY') {
                           $numbub = scalar(@{$analysis{$part_id.'.foils'}});
                       }
                   }
                   if (ref($analysis{$part_id.'.shown'}) eq 'ARRAY') {
                       $numshown = scalar(@{$analysis{$part_id.'.shown'}});
                   }
                   my $bubbles_per_line = 10;
                   my $inner_bubble_lines = int($numshown/$bubbles_per_line);
                   if (($numshown % $bubbles_per_line) != 0) {
                       $inner_bubble_lines++;
                   }
                   for (my $i=0; $i<$numshown; $i++) {
                       $subdivided_bubble_lines{$response_number} .= 
                           $inner_bubble_lines.',';
                   }
                   $subdivided_bubble_lines{$response_number} =~ s/,$//;
               } 
   
     $first_bubble_line{$response_number}           = $bubble_line;              $first_bubble_line{$response_number} = $bubble_line;
     $bubble_lines_per_response{$response_number}   = $lines;      $bubble_lines_per_response{$response_number} = $lines;
               $responsetype_per_response{$response_number} = 
                   $analysis{$part_id.'.type'};
     $response_number++;      $response_number++;
   
     $bubble_line +=  $lines;      $bubble_line +=  $lines;
Line 7030  sub scantron_validate_missingbubbles { Line 7436  sub scantron_validate_missingbubbles {
  # Probably here's where the error is...   # Probably here's where the error is...
   
  foreach my $missing (@{$$scan_record{'scantron.missingerror'}}) {   foreach my $missing (@{$$scan_record{'scantron.missingerror'}}) {
     if ($missing > $max_bubble) { next; }              my $lastbubble;
               if ($missing =~ /^(\d+)\.(\d+)$/) {
                  my $question = $1;
                  my $subquestion = $2;
                  if (!defined($first_bubble_line{$question -1})) { next; }
                  my $first = $first_bubble_line{$question-1};
                  my @subans = split(/,/,$subdivided_bubble_lines{$question-1});
                  my $subcount = 1;
                  while ($subcount<$subquestion) {
                      $first += $subans[$subcount-1];
                      $subcount ++;
                  }
                  my $count = $subans[$subquestion-1];
                  $lastbubble = $first + $count;
               } else {
                   if (!defined($first_bubble_line{$missing - 1})) { next; }
                   $lastbubble = $first_bubble_line{$missing - 1} + $bubble_lines_per_response{$missing - 1};
               }
               if ($lastbubble > $max_bubble) { next; }
     push(@to_correct,$missing);      push(@to_correct,$missing);
  }   }
  if (@to_correct) {   if (@to_correct) {
Line 7069  sub scantron_validate_missingbubbles { Line 7493  sub scantron_validate_missingbubbles {
   
 sub scantron_process_students {  sub scantron_process_students {
     my ($r) = @_;      my ($r) = @_;
   
     my (undef,undef,$sequence)=&Apache::lonnet::decode_symb($env{'form.selectpage'});      my (undef,undef,$sequence)=&Apache::lonnet::decode_symb($env{'form.selectpage'});
     my ($symb)=&get_symb($r);      my ($symb)=&get_symb($r);
     if (!$symb) {return '';}      if (!$symb) {
    return '';
       }
     my $default_form_data=&defaultFormData($symb);      my $default_form_data=&defaultFormData($symb);
   
     my %scantron_config=&get_scantron_config($env{'form.scantron_format'});      my %scantron_config=&get_scantron_config($env{'form.scantron_format'});
Line 7092  SCANTRONFORM Line 7519  SCANTRONFORM
     my @delayqueue;      my @delayqueue;
     my %completedstudents;      my %completedstudents;
           
       my $lock=&Apache::lonnet::set_lock(&mt('Grading bubblesheet exam'));
     my $count=&get_todo_count($scanlines,$scan_data);      my $count=&get_todo_count($scanlines,$scan_data);
     my %prog_state=&Apache::lonhtmlcommon::Create_PrgWin($r,'Scantron Status',      my %prog_state=&Apache::lonhtmlcommon::Create_PrgWin($r,'Scantron Status',
      'Scantron Progress',$count,       'Scantron Progress',$count,
Line 7103  SCANTRONFORM Line 7531  SCANTRONFORM
     my ($uname,$udom,$started);      my ($uname,$udom,$started);
   
     &scantron_get_maxbubble(); # Need the bubble lines array to parse.      &scantron_get_maxbubble(); # Need the bubble lines array to parse.
       
   
       # If an ssi failed in scantron_get_maxbubble, put an error message out to
       # the user and return.
   
       if ($ssi_error) {
    $r->print("</form>");
    &ssi_print_error($r);
    $r->print(&show_grading_menu_form($symb));
           &Apache::lonnet::remove_lock($lock);
    return ''; # Dunno why the other returns return '' rather than just returning.
       }
   
     while ($i<$scanlines->{'count'}) {      while ($i<$scanlines->{'count'}) {
   ($uname,$udom)=('','');    ($uname,$udom)=('','');
Line 7130  SCANTRONFORM Line 7570  SCANTRONFORM
   ($uname,$udom)=split(/:/,$uname);    ($uname,$udom)=split(/:/,$uname);
   
  &Apache::lonxml::clear_problem_counter();   &Apache::lonxml::clear_problem_counter();
   &Apache::lonnet::appenv(%$scan_record);    &Apache::lonnet::appenv($scan_record);
   
  if (&scantron_clear_skip($scanlines,$scan_data,$i)) {   if (&scantron_clear_skip($scanlines,$scan_data,$i)) {
     &scantron_putfile($scanlines,$scan_data);      &scantron_putfile($scanlines,$scan_data);
Line 7151  SCANTRONFORM Line 7591  SCANTRONFORM
  $form{'CODE'}=$scan_record->{'scantron.CODE'};   $form{'CODE'}=$scan_record->{'scantron.CODE'};
     } else {      } else {
  $form{'CODE'}='';   $form{'CODE'}='';
       } 
       my $result=&ssi_with_retries($resource->src(), $ssi_retries, %form);
       if ($ssi_error) {
    $ssi_error = 0; # So end of handler error message does not trigger.
    $r->print("</form>");
    &ssi_print_error($r);
    $r->print(&show_grading_menu_form($symb));
                   &Apache::lonnet::remove_lock($lock);
    return ''; # Why return ''?  Beats me.
     }      }
     my $result=&Apache::lonnet::ssi($resource->src(),%form);  
     if ($result ne '') {  
     }  
     if (&Apache::loncommon::connection_aborted($r)) { last; }      if (&Apache::loncommon::connection_aborted($r)) { last; }
  }   }
  $completedstudents{$uname}={'line'=>$line};   $completedstudents{$uname}={'line'=>$line};
Line 7164  SCANTRONFORM Line 7611  SCANTRONFORM
  &Apache::lonnet::delenv('scantron\.');   &Apache::lonnet::delenv('scantron\.');
     }      }
     &Apache::lonhtmlcommon::Close_PrgWin($r,\%prog_state);      &Apache::lonhtmlcommon::Close_PrgWin($r,\%prog_state);
       &Apache::lonnet::remove_lock($lock);
 #    my $lasttime = &Time::HiRes::time()-$start;  #    my $lasttime = &Time::HiRes::time()-$start;
 #    $r->print("<p>took $lasttime</p>");  #    $r->print("<p>took $lasttime</p>");
   
Line 7456  sub grading_menu { Line 7904  sub grading_menu {
                 $menudata->{'url'}.'" >'.                  $menudata->{'url'}.'" >'.
                 $menudata->{'name'}."</a></h3>\n";                  $menudata->{'name'}."</a></h3>\n";
         } else {          } else {
             $Str .='    <h3><input type="button" value="'.&mt('Verify Receipt').'" '.              $Str .='<hr /><input type="button" value="'.&mt('Verify Receipt').'" '.
                 $menudata->{'jscript'}.                  $menudata->{'jscript'}.
                 ' onClick="javascript:checkChoice(document.forms.gradingMenu,\'5\',\'verify\')" '.                  ' onClick="javascript:checkChoice(document.forms.gradingMenu,\'5\',\'verify\')" '.
                 ' /></h3>';                  ' /> '.
             $Str .= ('&nbsp;'x8).   &Apache::lonnet::recprefix($env{'request.course.id'}).
  &mt(' receipt: [_1]',                      '-<input type="text" name="receipt" size="4" onChange="javascript:checkReceiptNo(this.form,\'OK\')" />';
     &Apache::lonnet::recprefix($env{'request.course.id'}).  
                     '-<input type="text" name="receipt" size="4" onChange="javascript:checkReceiptNo(this.form,\'OK\')" />');  
         }          }
         $Str .= '    '.('&nbsp;'x8).$menudata->{'short_description'}.          $Str .= '    '.('&nbsp;'x8).$menudata->{'short_description'}.
             "\n";              "\n";
Line 7670  GRADINGMENUJS Line 8116  GRADINGMENUJS
       </div>        </div>
     </div>      </div>
   </form>';    </form>';
       $result .= &show_grading_menu_form($symb);
     return $result;      return $result;
 }  }
   
Line 7779  sub process_clicker { Line 8226  sub process_clicker {
     if (!$env{'form.upfiletype'}) { $env{'form.upfiletype'}='iclicker'; }      if (!$env{'form.upfiletype'}) { $env{'form.upfiletype'}='iclicker'; }
   
     my %checked;      my %checked;
     foreach my $gradingmechanism ('attendance','personnel','specific') {      foreach my $gradingmechanism ('attendance','personnel','specific','given') {
        if ($env{'form.gradingmechanism'} eq $gradingmechanism) {         if ($env{'form.gradingmechanism'} eq $gradingmechanism) {
           $checked{$gradingmechanism}="checked='checked'";            $checked{$gradingmechanism}="checked='checked'";
        }         }
Line 7790  sub process_clicker { Line 8237  sub process_clicker {
     my $attendance=&mt("Award points just for participation");      my $attendance=&mt("Award points just for participation");
     my $personnel=&mt("Correctness determined from response by course personnel");      my $personnel=&mt("Correctness determined from response by course personnel");
     my $specific=&mt("Correctness determined from response with clicker ID(s)");       my $specific=&mt("Correctness determined from response with clicker ID(s)"); 
       my $given=&mt("Correctness determined from given list of answers").' '.
                 '<font size="-2"><tt>('.&mt("Provide comma-separated list. Use '*' for any answer correct, '-' for skip").')</tt></font>';
     my $pcorrect=&mt("Percentage points for correct solution");      my $pcorrect=&mt("Percentage points for correct solution");
     my $pincorrect=&mt("Percentage points for incorrect solution");      my $pincorrect=&mt("Percentage points for incorrect solution");
     my $selectform=&Apache::loncommon::select_form($env{'form.upfiletype'},'upfiletype',      my $selectform=&Apache::loncommon::select_form($env{'form.upfiletype'},'upfiletype',
Line 7847  function sanitycheck() { Line 8296  function sanitycheck() {
 <br /><label><input type="radio" name="gradingmechanism" value="personnel" $checked{'personnel'} onClick="sanitycheck()" />$personnel</label>  <br /><label><input type="radio" name="gradingmechanism" value="personnel" $checked{'personnel'} onClick="sanitycheck()" />$personnel</label>
 <br /><label><input type="radio" name="gradingmechanism" value="specific" $checked{'specific'} onClick="sanitycheck()" />$specific </label>  <br /><label><input type="radio" name="gradingmechanism" value="specific" $checked{'specific'} onClick="sanitycheck()" />$specific </label>
 <input type="text" name="specificid" value="$env{'form.specificid'}" size="20" />  <input type="text" name="specificid" value="$env{'form.specificid'}" size="20" />
   <br /><label><input type="radio" name="gradingmechanism" value="given" $checked{'given'} onClick="sanitycheck()" />$given </label>
   <br />&nbsp;&nbsp;&nbsp;
   <input type="text" name="givenanswer" size="50" />
 <input type="hidden" name="waschecked" value="$env{'form.gradingmechanism'}" />  <input type="hidden" name="waschecked" value="$env{'form.gradingmechanism'}" />
 <br /><label>$pcorrect: <input type="text" name="pcorrect" size="4" value="$env{'form.pcorrect'}" onChange="sanitycheck()" /></label>  <br /><label>$pcorrect: <input type="text" name="pcorrect" size="4" value="$env{'form.pcorrect'}" onChange="sanitycheck()" /></label>
 <br /><label>$pincorrect: <input type="text" name="pincorrect" size="4" value="$env{'form.pincorrect'}" onChange="sanitycheck()" /></label>  <br /><label>$pincorrect: <input type="text" name="pincorrect" size="4" value="$env{'form.pincorrect'}" onChange="sanitycheck()" /></label>
Line 7873  sub process_clicker_file { Line 8325  sub process_clicker_file {
  $result.='<span class="LC_error">'.&mt('You need to specify a clicker ID for the correct answer').'</span>';   $result.='<span class="LC_error">'.&mt('You need to specify a clicker ID for the correct answer').'</span>';
  return $result.&show_grading_menu_form($symb);   return $result.&show_grading_menu_form($symb);
     }      }
       if (($env{'form.gradingmechanism'} eq 'given') && ($env{'form.givenanswer'}!~/\S/)) {
           $result.='<span class="LC_error">'.&mt('You need to specify the correct answer').'</span>';
           return $result.&show_grading_menu_form($symb);
       }
       my $foundgiven=0;
       if ($env{'form.gradingmechanism'} eq 'given') {
           $env{'form.givenanswer'}=~s/^\s*//gs;
           $env{'form.givenanswer'}=~s/\s*$//gs;
           $env{'form.givenanswer'}=~s/[^a-zA-Z0-9\.\*\-]+/\,/g;
           $env{'form.givenanswer'}=uc($env{'form.givenanswer'});
           my @answers=split(/\,/,$env{'form.givenanswer'});
           $foundgiven=$#answers+1;
       }
     my %clicker_ids=&gather_clicker_ids();      my %clicker_ids=&gather_clicker_ids();
     my %correct_ids;      my %correct_ids;
     if ($env{'form.gradingmechanism'} eq 'personnel') {      if ($env{'form.gradingmechanism'} eq 'personnel') {
Line 7891  sub process_clicker_file { Line 8356  sub process_clicker_file {
     }      }
     if ($env{'form.gradingmechanism'} eq 'attendance') {      if ($env{'form.gradingmechanism'} eq 'attendance') {
  $result.=&mt('Score based on attendance only');   $result.=&mt('Score based on attendance only');
       } elsif ($env{'form.gradingmechanism'} eq 'given') {
           $result.=&mt('Score based on [_1] ([_2] answers)','<tt>'.$env{'form.givenanswer'}.'</tt>',$foundgiven);
     } else {      } else {
  my $number=0;   my $number=0;
  $result.='<p><b>'.&mt('Correctness determined by the following IDs').'</b>';   $result.='<p><b>'.&mt('Correctness determined by the following IDs').'</b>';
Line 7936  sub process_clicker_file { Line 8403  sub process_clicker_file {
 <input type="hidden" name="pcorrect" value="$env{'form.pcorrect'}" />  <input type="hidden" name="pcorrect" value="$env{'form.pcorrect'}" />
 <input type="hidden" name="pincorrect" value="$env{'form.pincorrect'}" />  <input type="hidden" name="pincorrect" value="$env{'form.pincorrect'}" />
 ENDHEADER  ENDHEADER
       if ($env{'form.gradingmechanism'} eq 'given') {
          $result.='<input type="hidden" name="correct:given" value="'.$env{'form.givenanswer'}.'" />';
       } 
     my %responses;      my %responses;
     my @questiontitles;      my @questiontitles;
     my $errormsg='';      my $errormsg='';
Line 7948  ENDHEADER Line 8418  ENDHEADER
     }      }
     $result.='<br />'.&mt('Found [_1] question(s)',$number).'<br />'.      $result.='<br />'.&mt('Found [_1] question(s)',$number).'<br />'.
              '<input type="hidden" name="number" value="'.$number.'" />'.               '<input type="hidden" name="number" value="'.$number.'" />'.
              &mt('Awarding [_1] percent for corrion(s)',$number).'<br />'.  
              '<input type="hidden" name="number" value="'.$number.'" />'.  
              &mt('Awarding [_1] percent for correct and [_2] percent for incorrect responses',               &mt('Awarding [_1] percent for correct and [_2] percent for incorrect responses',
                  $env{'form.pcorrect'},$env{'form.pincorrect'}).                   $env{'form.pcorrect'},$env{'form.pincorrect'}).
              '<br />';               '<br />';
       if (($env{'form.gradingmechanism'} eq 'given') && ($number!=$foundgiven)) {
          $result.='<span class="LC_error">'.&mt('Number of given answers does not agree with number of questions in file.').'</span>';
          return $result.&show_grading_menu_form($symb);
       } 
 # Remember Question Titles  # Remember Question Titles
 # FIXME: Possibly need delimiter other than ":"  # FIXME: Possibly need delimiter other than ":"
     for (my $i=0;$i<$number;$i++) {      for (my $i=0;$i<$number;$i++) {
Line 7996  ENDHEADER Line 8468  ENDHEADER
     }      }
     $result.='<hr />'.      $result.='<hr />'.
              &mt('Found [_1] registered and [_2] unregistered clickers.',$student_count,$unknown_count);               &mt('Found [_1] registered and [_2] unregistered clickers.',$student_count,$unknown_count);
     if ($env{'form.gradingmechanism'} ne 'attendance') {      if (($env{'form.gradingmechanism'} ne 'attendance') && ($env{'form.gradingmechanism'} ne 'given')) {
        if ($correct_count==0) {         if ($correct_count==0) {
           $errormsg.="Found no correct answers answers for grading!";            $errormsg.="Found no correct answers answers for grading!";
        } elsif ($correct_count>1) {         } elsif ($correct_count>1) {
Line 8141  ENDHEADER Line 8613  ENDHEADER
        if ($user) {          if ($user) { 
           my @answer=split(/\,/,$env{$key});            my @answer=split(/\,/,$env{$key});
           my $sum=0;            my $sum=0;
             my $realnumber=$number;
           for (my $i=0;$i<$number;$i++) {            for (my $i=0;$i<$number;$i++) {
              if ($answer[$i]) {               if ($answer[$i]) {
                 if ($gradingmechanism eq 'attendance') {                  if ($gradingmechanism eq 'attendance') {
                    $sum+=$pcorrect;                     $sum+=$pcorrect;
                   } elsif ($answer[$i] eq '*') {
                      $sum+=$pcorrect;
                   } elsif ($answer[$i] eq '-') {
                      $realnumber--;
                 } else {                  } else {
                    if ($answer[$i] eq $correct[$i]) {                     if ($answer[$i] eq $correct[$i]) {
                       $sum+=$pcorrect;                        $sum+=$pcorrect;
Line 8154  ENDHEADER Line 8631  ENDHEADER
                 }                  }
              }               }
           }            }
           my $ave=$sum/(100*$number);            my $ave=$sum/(100*$realnumber);
 # Store  # Store
           my ($username,$domain)=split(/\:/,$user);            my ($username,$domain)=split(/\:/,$user);
           my %grades=();            my %grades=();
Line 8197  sub handler { Line 8674  sub handler {
  &Apache::lonnet::logthis("grades got multiple commands ".join(':',@commands));   &Apache::lonnet::logthis("grades got multiple commands ".join(':',@commands));
     }      }
   
       $ssi_error = 0;
     $request->print(&Apache::loncommon::start_page('Grading'));      $request->print(&Apache::loncommon::start_page('Grading'));
     if ($symb eq '' && $command eq '') {      if ($symb eq '' && $command eq '') {
  if ($env{'user.adv'}) {   if ($env{'user.adv'}) {
Line 8210  sub handler { Line 8687  sub handler {
  if ($tsymb) {   if ($tsymb) {
     my ($map,$id,$url)=&Apache::lonnet::decode_symb($tsymb);      my ($map,$id,$url)=&Apache::lonnet::decode_symb($tsymb);
     if (&Apache::lonnet::allowed('mgr',$tcrsid)) {      if (&Apache::lonnet::allowed('mgr',$tcrsid)) {
  $request->print(&Apache::lonnet::ssi_body('/res/'.$url,   $request->print(&ssi_with_retries('/res/'.$url, $ssi_retries,
   ('grade_username' => $tuname,    ('grade_username' => $tuname,
    'grade_domain' => $tudom,     'grade_domain' => $tudom,
    'grade_courseid' => $tcrsid,     'grade_courseid' => $tcrsid,
Line 8297  sub handler { Line 8774  sub handler {
     $request->print("Access Denied ($command)");      $request->print("Access Denied ($command)");
  }   }
     }      }
       if ($ssi_error) {
    &ssi_print_error($request);
       }
     $request->print(&Apache::loncommon::end_page());      $request->print(&Apache::loncommon::end_page());
     &reset_caches();      &reset_caches();
     return '';      return '';
Removed from v.1.494  
changed lines
  Added in v.1.522

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>