Annotation of loncom/interface/lonpdfupload.pm, revision 1.21

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

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