Return to lonpdfupload.pm CVS log

Up to [LON-CAPA] / loncom / interface

fixed bug 6782, and escaped most localized messages used in Javascript blocks to make sure bugs like that do not happen again

    1: # The LearningOnline Network with CAPA
    2: # PDF Form Upload Handler
    3: #
    4: # $Id: lonpdfupload.pm,v 1.25 2015/06/09 21:22:57 damieng 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::lonnavmaps();
   36: use Apache::lonlocal;
   37: use File::MMagic;
   38: use CAM::PDF;
   39: use LONCAPA qw(:DEFAULT :match);
   40: 
   41: use strict;
   42: 
   43: sub handler() {
   44:     my $r = shift;
   45:     &Apache::loncommon::content_type($r,'text/html');
   46:     $r->send_http_header;
   47:     return OK if $r->header_only;
   48: 
   49:     #  Needs to be in a course
   50:     if (!$env{'request.course.fn'}) {
   51:         # Not in a course
   52:         $env{'user.error.msg'}="/adm/pdfupload:bre:0:0:Cannot upload PDF forms unless in a course";
   53:         return HTTP_NOT_ACCEPTABLE;
   54:     }
   55: 
   56:     # Breadcrumbs
   57:     my $brcrum = [{'href' => '/adm/pdfupload',
   58:                    'text' => 'Upload PDF Form'}];
   59:     if ($env{'form.Uploaded'} && $env{'form.file'}) {
   60:         push(@{$brcrum},{'href'  => '',
   61:                          'text'  => 'PDF upload result'});
   62:     }
   63: 
   64:     $r->print(&Apache::loncommon::start_page('Upload PDF Form',
   65:                                              undef,
   66:                                              {'bread_crumbs' => $brcrum,})
   67:     );
   68: 
   69:     if ($env{'request.course.id'}) {
   70:         my $permission = $env{'course.'.$env{'request.course.id'}.'.canuse_pdfforms'};
   71:         if ($permission eq '') {
   72:             my %domdefs = &Apache::lonnet::get_domain_defaults($env{'course.'.$env{'request.course.id'}.'.domain'});
   73:             $permission = $domdefs{'canuse_pdfforms'};
   74:         }
   75:         unless ($permission) {
   76:             $r->print('<p class="LC_warning">'.
   77:                       &mt('Upload of PDF forms is not permitted for this course.').
   78:                       '</p>'.
   79:                       &Apache::loncommon::end_page());
   80:             return OK;
   81:         }
   82:     } else {
   83:         $r->print('<p class="LC_warning">'.
   84:                   &mt('Could not determine identity of this course.').' '.
   85:                   &mt('You may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
   86:                   '</p>'.
   87:                   &Apache::loncommon::end_page());
   88:         return OK;
   89:     }
   90: 
   91:     # if a file was upload
   92:     if($env{'form.Uploaded'} && $env{'form.file'}) {
   93:         my $mm = new File::MMagic;
   94:         my $mime_type = $mm->checktype_contents($env{'form.file'});
   95:         if ($mime_type eq 'application/pdf') {
   96:             $r->print(&processPDF);
   97:         } else {
   98:             $r->print('<p class="LC_error">'
   99:                      .&mt("The uploaded file does not appear to be a PDF file.")
  100:                      .'</p>');
  101:         }
  102:     } else { 
  103:         # print upload form
  104:         $r->print(&get_javascripts);
  105:         $r->print(&get_uploadform);
  106:     }
  107: 
  108:     #link to course-content
  109:     $r->print('<hr />'
  110:              .'<p>'."\n"
  111:              .'<a href="/adm/navmaps">'."\n"
  112:              .&mt('Course Contents')."\n"
  113:              .'</a>'."\n"
  114:              .'</p>'."\n"
  115:     );
  116: 
  117:     #&dumpenv($r); #debug -> prints the environment
  118:     $r->print(&Apache::loncommon::end_page());
  119:     return OK;
  120: }
  121: 
  122: sub get_javascripts() {
  123:     
  124:     my $message = &mt('Please choose a PDF-File.');
  125:     &js_escape(\$message);
  126: 
  127:     # simple test if the upload ends with ".pdf"
  128:     # it's only for giving a message to the user
  129:     my $result .= <<END
  130:   <script type="text/javascript">
  131: // <![CDATA[
  132:     function checkFilename(form) {
  133:         var fileExt = form.file.value;
  134:         fileExt = fileExt.match(/[.]pdf\$/gi);
  135:         if(fileExt) {
  136:             return true;
  137:         }
  138:         alert("$message");
  139:         return false;
  140:     }
  141: // ]]>
  142:   </script>
  143: END
  144: ;
  145:     return $result; 
  146: }
  147: 
  148: 
  149: sub get_uploadform() {
  150:     
  151:     my %lt = &Apache::lonlocal::texthash(
  152:                  'title'  => 'Upload a PDF Form with filled Form Fields', 
  153:                  'chFile' => 'File',
  154:                  'submit' => 'Upload',
  155:              );
  156: 
  157:     my $result = 
  158:         '<br />'
  159:        .'<form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);" action="">'
  160:        .&Apache::lonhtmlcommon::start_pick_box()
  161:        .&Apache::lonhtmlcommon::row_headline()
  162:        .'<h2>'.$lt{'title'}.'</h2>'
  163:        .&Apache::lonhtmlcommon::row_closure()
  164:        .&Apache::lonhtmlcommon::row_title($lt{'chFile'})
  165:        .'<input type="file" name="file" id="filename" />'
  166:        .&Apache::lonhtmlcommon::row_closure(1)
  167:        .&Apache::lonhtmlcommon::end_pick_box()
  168:        .'<p>'
  169:        .'<input type="submit" name="Uploaded" value="'.$lt{'submit'}.'" />'
  170:        .'</p>'
  171:        .'</form>'
  172:        .'<br />';
  173: 
  174:   return $result;
  175: }
  176: 
  177: sub processPDF {
  178:     my $result = ();  # message for Browser
  179:     my @pdfdata = (); # answers from PDF-Forms
  180:     
  181:     @pdfdata = &get_pdf_data(); # get answers from PDF-Form
  182:     
  183:     if (scalar @pdfdata) {    
  184:         &grade_pdf(@pdfdata);
  185:     } else {
  186:         $result .= '<p class="LC_error">'
  187:                   .&mt("Can't find any valid PDF form fields.")
  188:                   .'</p>';
  189:     }
  190: }
  191: 
  192: sub get_pdf_data() {
  193:     my @data = ();
  194:     my $pdf = CAM::PDF->new($env{'form.file'});
  195: 
  196:     if($pdf) {
  197:         my @formFields = $pdf->getFormFieldList(); #get names of form fields
  198: 
  199:         foreach my $field (@formFields) {
  200:             my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get form field dictonary
  201: 
  202:             # this is necessary because CAM::PDF has a problem with form fieldnames which include a
  203:             # dot in fieldnames. So a fieldname like "i.am.aFormfield" will offer three fieldnames
  204:             # "i", "i.am" and "i.am.aFormfield". The fragmentary names keep no values and will be ignored.
  205:             if($dict->{'V'}) {
  206:                 push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
  207:             }
  208:         }
  209:     }
  210:     return @data;
  211: }
  212: 
  213: sub grade_pdf {
  214:     my @pdfdata = @_;
  215:     my ($result,$meta,%grades,%problems,%foreigncourse,$debug);
  216: 
  217:     my $navmap = Apache::lonnavmaps::navmap->new();
  218:     if (!defined($navmap)) {
  219:         $result = '<h3>'.&mt('Verification of PDF form items failed').'</h3>'.
  220:                   '<div class="LC_error">'.
  221:                   &mt('Unable to retrieve information about course contents').' '.
  222:                   &mt('You may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
  223:                   '</div>';
  224:         return $result;
  225:     }
  226:     my %restitles;
  227:     foreach my $res ($navmap->retrieveResources()) {
  228:         my $symb = $res->symb; 
  229:         $restitles{$symb} = $res->compTitle();
  230:     }
  231:    
  232:     $debug  .= "Found: ". scalar @pdfdata." Entries \n";
  233: 
  234:     foreach my $entry (sort(@pdfdata)) {
  235:         if ($entry =~ /^meta.*/) {
  236:             $debug .= 'found: metadata -> '.$entry . "<br />";
  237:             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
  238:             my ($domain, $user) = split('&', $value);
  239:             $user =~ s/(.*)\n/$1/; #TODO is that equals to chomp?
  240:             if($user ne $env{'user.name'} or  $domain ne $env{'user.domain'}) {
  241:                 return '<p class="LC_error">'
  242:                       .&mt('Wrong username ([_1]) found in PDF file. Expected username: [_2]'
  243:                           ,$user.':'.$domain
  244:                           ,$env{'user.domain'}.':'.$env{'user.name'})
  245:                       .'</p>';
  246:             }
  247: 
  248:         } elsif ($entry =~ /^upload.*/)  {
  249:             $debug .= 'found: a problem -> '.$entry;
  250:             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
  251:             my ($symb, $part, $type, $HWVAL) = split('&', $label);
  252:             my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
  253:             if ($map =~ m{^uploaded/($match_domain)/($match_courseid)/default(_?\d*)\.(page|sequence)}) {
  254:                 my $mapcid = $1.'_'.$2;
  255:                 if ($mapcid ne $env{'request.course.id'}) {
  256:                     push(@{$foreigncourse{$mapcid}},$symb);
  257:                 }
  258:             }
  259:             next unless (exists($restitles{$symb}));
  260:             $value =~ s/(.*)\n/$1/; 
  261: 
  262:             #filter incorrect radiobuttons (Bug in CABAReT Stage)
  263:             if ($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
  264:                 next;
  265:             }
  266:  
  267:             my $submit = $part;
  268:             $submit =~ s/part_(.*)/submit_$1/;
  269:             if ($problems{$symb.$part}) {
  270:                  $problems{$symb.$part}{$HWVAL} = $value;
  271:             } else {
  272:                  $problems{$symb.$part} =  { 'resource' => $resource,
  273:                                         'symb' => $symb,
  274:                                         'submitted' => $part,
  275:                                         $submit => 'Answer',
  276:                                         $HWVAL => $value};
  277:             }
  278:         } else {
  279:             $debug .= 'found: -> '.$entry;
  280:             next;
  281:         }
  282:     }
  283:     #$result .= $debug;
  284: 
  285:     $result .= '<h3>'.&mt('Result of PDF Form upload').'</h3>';
  286: 
  287:     if (keys(%problems) > 0) {
  288:         $result .= &Apache::loncommon::start_data_table()
  289:                   .&Apache::loncommon::start_data_table_header_row()
  290:                   .'<th>'.&mt('Problem Name').'</th>'
  291:                   .'<th>'.&mt('Grading').'</th>'
  292:                   .&Apache::loncommon::start_data_table_header_row()
  293:                   .&Apache::loncommon::end_data_table_header_row();
  294: 
  295:         foreach my $key (sort(keys(%problems))) {
  296:             my %problem = %{$problems{$key}};
  297:             my ($problemname, $grade) = &grade_problem(%problem);
  298: 
  299:             $result .= &Apache::loncommon::start_data_table_row();
  300:             $result .= '<td><a href="/res/'.$problem{'resource'}.
  301:                        '?symb='.
  302:                        &HTML::Entities::encode($problem{'symb'},'"&<>').
  303:                        '">'.$problemname.'</a></td><td><span class="';
  304:             if ($grade eq "EXACT_ANS" || $grade eq "APPROX_ANS") {
  305:                 $result .= 'LC_answer_correct';
  306:             } elsif ($grade eq "DRAFT") {
  307:                 $result .= 'LC_answer_not_charged_try';
  308:             } else {
  309:                 $result .= 'LC_answer_charged_try';
  310:             }
  311:             $result .= '">';
  312:             $grade = &parse_grade_answer($grade);
  313:             $result .= $grade.'</span></td>';
  314:             $result .= &Apache::loncommon::end_data_table_row();
  315:         }
  316:         $result .= &Apache::loncommon::end_data_table();
  317:     } else {
  318:         $result .= '<p class="LC_warning">'.
  319:                    &mt('As no gradable form items were found, no submissions have been recorded.').
  320:                    '</p>';
  321:     }
  322:     if (keys(%foreigncourse)) {
  323:         my ($numother,$othercrsmsg);
  324:         foreach my $cid (sort(keys(%foreigncourse))) {
  325:             my %coursehash = &Apache::lonnet::coursedescription($cid,
  326:                                                           {'one_time' => 1});
  327:             if (ref($foreigncourse{$cid}) eq 'ARRAY') {
  328:                 if ($numother) {
  329:                     $othercrsmsg .= '</li><li>';
  330:                 }
  331:                 $othercrsmsg .= '<b>'.$coursehash{'description'}.'</b><ul>'."\n";
  332:                 foreach my $symb (@{$foreigncourse{$cid}}) {
  333:                     my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
  334:                     $othercrsmsg .= '<li>'.$resource.'</li>';
  335:                 }
  336:                 $othercrsmsg .= '</ul>';
  337:                 $numother ++;
  338:             }
  339:         }
  340:         if ($numother) {
  341:             $result .= '<div class="LC_warning">';
  342:             if ($numother > 1) {
  343:                 $result .= &mt('Your uploaded PDF form contained the following resource(s) from [_1] different courses:','<b>'.$numother.'</b>')."\n".'<ul><li>'.
  344:                            $othercrsmsg.'</li></ul>';
  345:             } else {
  346:                 $result .= &mt('Your uploaded PDF form contained the following resource(s) from a different course:').' '.$othercrsmsg.
  347:                            &mt('Did you download the PDF form from another course and upload it to the wrong course?'); 
  348:             }
  349:             $result .= '</div>';
  350:         }
  351:     }
  352: 
  353:     return $result;
  354: }
  355: 
  356: sub grade_problem {
  357:     my %problem = @_;
  358:     my ($title, $part) = ();
  359: 
  360:     &Apache::loncommon::ssi_with_retries('/res/'.$problem{'resource'}, 5, %problem);
  361: 
  362:     $title = &Apache::lonnet::gettitle($problem{'symb'});    
  363:     $part = $problem{submitted};
  364:     $part =~ s/part_(.*)/$1/;
  365:     unless($part eq '0') {
  366:         #add information about part number
  367:         $title .= " - Part $part";
  368:     }
  369:  
  370:     my %problemhash = &Apache::lonnet::restore($problem{'symb'});
  371:     my $grade = $problemhash{"resource.$part.award"};
  372: 
  373:     return ($title, $grade);    
  374: }
  375: 
  376: sub parse_grade_answer {
  377:     my ($shortcut) = @_;
  378:      my %answerhash = ('EXACT_ANS' => &mt('You are correct.'),
  379:                        'APPROX_ANS' => &mt('You are correct.'),
  380:                        'INCORRECT' => &mt('You are incorrect'),
  381:                        'DRAFT' => &mt('Copy saved but not submitted.'),
  382:      );
  383: 
  384:     foreach my $key (keys(%answerhash)) {
  385:         if($shortcut eq $key) {
  386:             return $answerhash{$shortcut};
  387:         }  
  388:     }
  389:     return &mt('See course contents for further information.');
  390: 
  391: }
  392: 
  393: 
  394: sub dumpenv  {
  395:     my $r = shift;
  396: 
  397:     $r->print ("<br />-------------------<br />");
  398:     foreach my $key (sort(keys(%env))) {
  399:         $r->print ("<br />$key -> $env{$key}");
  400:     }
  401:     $r->print ("<br />-------------------<br />");
  402:     $r->print ("<br />-------------------<br />");
  403:     foreach my $key (sort(keys(%ENV))) {
  404:         $r->print ("<br />$key -> $ENV{$key}");
  405:     }
  406:     $r->print ("<br />-------------------<br />");
  407:     
  408: }	
  409: 
  410: 1;
  411: __END__
  412: