Return to lonpdfupload.pm CVS log

Up to [LON-CAPA] / loncom / interface

- Check resource is in course, before making submission.
- Display warning instead of grade display if no form items were found in course map.
- Some coding style changes: keys().

    1: # The LearningOnline Network with CAPA
    2: # PDF Form Upload Handler
    3: #
    4: # $Id: lonpdfupload.pm,v 1.17 2010/03/18 16:08:48 raeburn Exp $
    5: #
    6: # Copyright Michigan State University Board of Trustees
    7: #
    8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
    9: #
   10: # LON-CAPA is free software; you can redistribute it and/or modify
   11: # it under the terms of the GNU General Public License as published by
   12: # the Free Software Foundation; either version 2 of the License, or
   13: # (at your option) any later version.
   14: #
   15: # LON-CAPA is distributed in the hope that it will be useful,
   16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18: # GNU General Public License for more details.
   19: #
   20: # You should have received a copy of the GNU General Public License
   21: # along with LON-CAPA; if not, write to the Free Software
   22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   23: #
   24: # /home/httpd/html/adm/gpl.txt
   25: #
   26: # http://www.lon-capa.org/
   27: #
   28: package Apache::lonpdfupload;
   29: 
   30: use lib '/home/httpd/lib/perl';
   31: use Apache::Constants qw(:common :http);
   32: use Apache::lonnet;
   33: use Apache::lonhtmlcommon();
   34: use Apache::loncommon();
   35: use Apache::lonlocal;
   36: use File::MMagic;
   37: use CAM::PDF;
   38: 
   39: use strict;
   40: 
   41: sub handler() {
   42:     my $r = shift;
   43:     &Apache::loncommon::content_type($r,'text/html');
   44:     $r->send_http_header;
   45:     return OK if $r->header_only;
   46: 
   47:     #  Needs to be in a course
   48:     if (!$env{'request.course.fn'}) {
   49:         # Not in a course
   50:         $env{'user.error.msg'}="/adm/pdfupload:bre:0:0:Cannot upload PDF forms unless in a course";
   51:         return HTTP_NOT_ACCEPTABLE;
   52:     }
   53: 
   54:     # Breadcrumbs
   55:     my $brcrum = [{'href' => '/adm/pdfupload',
   56:                    'text' => 'Upload PDF Form'}];
   57:     if ($env{'form.Uploaded'} && $env{'form.file'}) {
   58:         push(@{$brcrum},{'href'  => '',
   59:                          'text'  => 'PDF upload result'});
   60:     }
   61: 
   62:     $r->print(&Apache::loncommon::start_page('Upload PDF Form',
   63:                                              undef,
   64:                                              {'bread_crumbs' => $brcrum,})
   65:     );
   66: 
   67:     if ($env{'request.course.id'}) {
   68:         my $permission = $env{'course.'.$env{'request.course.id'}.'.canuse_pdfforms'};
   69:         if ($permission eq '') {
   70:             my %domdefs = &Apache::lonnet::get_domain_defaults($env{'course.'.$env{'request.course.id'}.'.domain'});
   71:             $permission = $domdefs{'canuse_pdfforms'};
   72:         }
   73:         unless ($permission) {
   74:             $r->print('<p class="LC_warning">'.
   75:                       &mt('Upload of PDF forms is not permitted for this course.').
   76:                       '</p>'.
   77:                       &Apache::loncommon::end_page());
   78:             return OK;
   79:         }
   80:     } else {
   81:         $r->print('<p class="LC_warning">'.
   82:                   &mt('Could not determine identity of this course. you may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
   83:                   '</p>'.
   84:                   &Apache::loncommon::end_page());
   85:         return OK;
   86:     }
   87: 
   88:     # if a file was upload
   89:     if($env{'form.Uploaded'} && $env{'form.file'}) {
   90:         my $mm = new File::MMagic;
   91:         my $mime_type = $mm->checktype_contents($env{'form.file'});
   92:         if ($mime_type eq 'application/pdf') {
   93:             $r->print(&processPDF);
   94:         } else {
   95:             $r->print('<p class="LC_error">'
   96:                      .&mt("The uploaded file does not appear to be a PDF file.")
   97:                      .'</p>');
   98:         }
   99:     } else { 
  100:         # print upload form
  101:         $r->print(&get_javascripts);
  102:         $r->print(&get_uploadform);
  103:     }
  104: 
  105:     #link to course-content
  106:     $r->print('<hr />'
  107:              .'<p>'."\n"
  108:              .'<a href="/adm/navmaps">'."\n"
  109:              .&mt('Course Contents')."\n"
  110:              .'</a>'."\n"
  111:              .'</p>'."\n"
  112:     );
  113: 
  114:     #&dumpenv($r); #debug -> prints the environment
  115:     $r->print(&Apache::loncommon::end_page());
  116:     return OK;
  117: }
  118: 
  119: sub get_javascripts() {
  120:     
  121:     my $message = &mt('Please choose a PDF-File.');
  122: 
  123:     # simple test if the upload ends with ".pdf"
  124:     # it's only for giving a message to the user
  125:     my $result .= <<END
  126:   <script type="text/javascript">
  127:     function checkFilename(form) {
  128:         var fileExt = form.file.value;
  129:         fileExt = fileExt.match(/[.]pdf\$/g);
  130:         if(fileExt) {
  131:             return true;
  132:         }
  133:         alert("$message");
  134:         return false;
  135:     }
  136:   </script>
  137: END
  138: ;
  139:     return $result; 
  140: }
  141: 
  142: 
  143: sub get_uploadform() {
  144:     
  145:     my %lt = &Apache::lonlocal::texthash(
  146:                  'title'  => 'Upload a PDF Form with filled Form Fields', 
  147:                  'chFile' => 'File',
  148:                  'submit' => 'Upload',
  149:              );
  150: 
  151:     my $result = 
  152:         '<br />'
  153:        .'<form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);">'
  154:        .'<input type="hidden" name="type" value="upload" />'
  155:        .&Apache::lonhtmlcommon::start_pick_box()
  156:        .&Apache::lonhtmlcommon::row_headline()
  157:        .'<h2>'.$lt{'title'}.'</h2>'
  158:        .&Apache::lonhtmlcommon::row_closure()
  159:        .&Apache::lonhtmlcommon::row_title($lt{'chFile'})
  160:        .'<input type="file" name="file" id="filename" />'
  161:        .&Apache::lonhtmlcommon::row_closure(1)
  162:        .&Apache::lonhtmlcommon::end_pick_box()
  163:        .'<p>'
  164:        .'<input type="submit" name="Uploaded" value="'.$lt{'submit'}.'" />'
  165:        .'</p>'
  166:        .'</form>'
  167:        .'<br />';
  168: 
  169:   return $result;
  170: }
  171: 
  172: sub processPDF {
  173:     my $result = ();  # message for Browser
  174:     my @pdfdata = (); # answers from PDF-Forms
  175:     
  176:     @pdfdata = &get_pdf_data(); # get answers from PDF-Form
  177:     
  178:     if (scalar @pdfdata) {    
  179:         &grade_pdf(@pdfdata);
  180:     } else {
  181:         $result .= '<p class="LC_error">'
  182:                   .&mt("Can't find any valid PDF formfields.")
  183:                   .'</p>';
  184:     }
  185: }
  186: 
  187: sub get_pdf_data() {
  188:     my @data = ();
  189:     my $pdf = CAM::PDF->new($env{'form.file'});
  190: 
  191:     my @formFields = $pdf->getFormFieldList(); #get names of formfields
  192:     
  193:     foreach my $field (@formFields) {
  194: 	my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get formfield dictonary
  195: 
  196:         #
  197:         # this is necessary because CAM::PDF has a problem with formfieldnames which include a
  198:         # dot in fieldnames. So a fieldname like "i.am.aFormfield" will offer three fieldnames "i", "i.am" 
  199:         # and "i.am.aFormfield". The fragmentary names keep no values and will be ignored.
  200:         if($dict->{'V'}) {
  201:             push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
  202:         }
  203:     } 
  204:     return @data;
  205: }
  206: 
  207: sub grade_pdf {
  208:     my $result = ();
  209:     my @pdfdata = @_;
  210:     my ($result,$meta,%grades,%problems,$debug);   
  211:    
  212:     $debug  .= "Found: ". scalar @pdfdata." Entries \n";
  213: 
  214:     foreach my $entry (sort(@pdfdata)) {
  215:         if ($entry =~ /^meta.*/) {
  216:             $debug .= 'found: metadata -> '.$entry . "<br />";
  217:             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
  218:             my ($domain, $user) = split('&', $value);
  219:             $user =~ s/(.*)\n/$1/; #TODO is that equals to chomp?
  220:             
  221:             if($user ne $env{'user.name'} or  $domain ne $env{'user.domain'}) {
  222:                 return '<p class="LC_error">'
  223:                       .&mt('Wrong username ([_1]) found in PDF file. Expected username: [_2]'
  224:                           ,$user.':'.$domain
  225:                           ,$env{'user.domain'}.':'.$env{'user.name'})
  226:                       .'</p>';
  227:             }
  228: 
  229:         } elsif ($entry =~ /^upload.*/)  {
  230:             $debug .= 'found: a problem -> '.$entry;
  231:             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
  232:             my ($symb, $part, $type, $HWVAL) = split('&', $label);
  233:             my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
  234:             next unless (&Apache::lonnet::is_on_map($resource));
  235:             $value =~ s/(.*)\n/$1/; 
  236: 
  237:             #filter incorrect radiobuttons (Bug in CABAReT Stage)
  238:             if ($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
  239:                 next;
  240:             }
  241:  
  242:             my $submit = $part;
  243:             $submit =~ s/part_(.*)/submit_$1/;
  244:             if ($problems{$symb.$part}) {
  245:                  $problems{$symb.$part}{$HWVAL} = $value;
  246:             } else {
  247:                  $problems{$symb.$part} =  { 'resource' => $resource,
  248:                                         'symb' => $symb,
  249:                                         'submitted' => $part,
  250:                                         $submit => 'Answer',
  251:                                         $HWVAL => $value};
  252:             }
  253:         } else {
  254:             $debug .= 'found: -> '.$entry;
  255:             next;
  256:         }
  257:     }
  258:     #$result .= $debug;
  259: 
  260:     $result .= '<h2>'.&mt('Results of PDF Form problems').'</h2>';
  261: 
  262:     if (keys(%problems) > 0) {
  263:         $result .= &Apache::loncommon::start_data_table()
  264:                   .&Apache::loncommon::start_data_table_header_row()
  265:                   .'<th>'.&mt('Problem Name').'</th>'
  266:                   .'<th>'.&mt('Grading').'</th>'
  267:                   .&Apache::loncommon::start_data_table_header_row()
  268:                   .&Apache::loncommon::end_data_table_header_row();
  269: 
  270:         foreach my $key (sort(keys(%problems))) {
  271:             my %problem = %{$problems{$key}};
  272:             my ($problemname, $grade) = &grade_problem(%problem);
  273: 
  274:             $result .= &Apache::loncommon::start_data_table_row();
  275:             $result .= "<td>$problemname</td><td class='";
  276:             if ($grade eq "EXACT_ANS" || $grade eq "APPROX_ANS") {
  277:                 $result .= "LC_answer_correct";
  278:             } else { 
  279:                 $result .= "LC_answer_charged_try";
  280:             }
  281:             $grade = &parse_grade_answer($grade);
  282:             $result .= "'>$grade</span></td>";
  283:             $result .= &Apache::loncommon::end_data_table_row();
  284:         }
  285:         $result .= &Apache::loncommon::end_data_table();
  286:     } else {
  287:         $result .= '<p class="LC_warning">'.
  288:                    &mt('As no gradable form items were found, no submissions have been recorded.').
  289:                    '</p>';
  290:     }
  291: 
  292:     return $result;        
  293: }
  294: 
  295: sub grade_problem {
  296:     my %problem = @_;
  297:     my ($title, $part) = ();
  298: 
  299:     &Apache::loncommon::ssi_with_retries('/res/'.$problem{'resource'}, 5, %problem);
  300: 
  301:     $title = &Apache::lonnet::gettitle($problem{'symb'});    
  302:     $part = $problem{submitted};
  303:     $part =~ s/part_(.*)/$1/;
  304:     unless($part eq '0') {
  305:         #add information about part number
  306:         $title .= " - Part $part";
  307:     }
  308:  
  309:     my %problemhash = &Apache::lonnet::restore($problem{'symb'});
  310:     my $grade = $problemhash{"resource.$part.award"};
  311: 
  312:     return ($title, $grade);    
  313: }
  314: 
  315: sub parse_grade_answer {
  316:     my ($shortcut) = @_;
  317:      my %answerhash = ('EXACT_ANS' => &mt('You are correct.'),
  318:                        'APPROX_ANS' => &mt('You are correct.'),
  319:                        'INCORRECT' => &mt('You are incorrect'),
  320:      );
  321: 
  322:     foreach my $key (keys %answerhash) {
  323:         if($shortcut eq $key) {
  324:             return $answerhash{$shortcut};
  325:         }  
  326:     }
  327:     return &mt('See course contents for further information.');
  328: 
  329: }
  330: 
  331: 
  332: sub dumpenv  {
  333:     my $r = shift;
  334: 
  335:     $r->print ("<br />-------------------<br />");
  336:     foreach my $key (sort (keys %env)) {
  337:         $r->print ("<br />$key -> $env{$key}");
  338:     }
  339:     $r->print ("<br />-------------------<br />");
  340:     $r->print ("<br />-------------------<br />");
  341:     foreach my $key (sort (keys %ENV)) {
  342:         $r->print ("<br />$key -> $ENV{$key}");
  343:     }
  344:     $r->print ("<br />-------------------<br />");
  345:     
  346: }	
  347: 
  348: 1;
  349: __END__
  350: