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

1.1       onken       1: # The LearningOnline Network with CAPA
1.12      bisitz      2: # PDF Form Upload Handler
1.1       onken       3: #
1.14    ! raeburn     4: # $Id: lonpdfupload.pm,v 1.13 2009/06/17 13:00:38 bisitz 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);
                     32: use LONCAPA;
                     33: use LONCAPA::loncgi;
                     34: use File::Path;
                     35: use File::Basename;
                     36: use File::Copy;
                     37: use IO::File;
                     38: use Image::Magick;
                     39: use Apache::lonacc;
                     40: use Apache::lonxml;
                     41: use Apache::lonhtmlcommon();
                     42: use Apache::lonnet;
                     43: use Apache::loncommon();
                     44: use Apache::lonlocal;
                     45: use Apache::lonmsg();
                     46: use Apache::lonhomework;
                     47: use LONCAPA::Enrollment;
                     48: use LONCAPA::Configuration;
1.2       onken      49: use CAM::PDF;
1.1       onken      50: 
                     51: use strict;
                     52: 
                     53: sub handler() {
1.2       onken      54:     my $r = shift;
                     55: 
                     56:     # check user permissions 
                     57:     if(!&checkpermission($r)) {
                     58:         # stop processing 
                     59:         return OK;
                     60:     }
                     61: 
                     62:     $Apache::lonxml::request=$r;
                     63:     $Apache::lonxml::debug=$env{'user.debug'};
                     64: 
                     65:     $env{'request.uri'}=$r->uri;
                     66:     $r->content_type('text/html');
                     67:     $r->send_http_header();
1.13      bisitz     68: 
                     69:     # Breadcrumbs
                     70:     my $brcrum = [{'href' => '/pdfupload',
                     71:                    'text' => 'Upload PDF Form'}];
                     72: 
                     73:     $r->print(&Apache::loncommon::start_page('Upload PDF Form',
                     74:                                              undef,
                     75:                                              {'bread_crumbs' => $brcrum,})
                     76:     );
1.2       onken      77: 
                     78:     #load post data into environment
                     79:     &Apache::lonacc::get_posted_cgi($r);
                     80: 
                     81:     # if a file was upload
                     82:     if($env{'form.Uploaded'} && $env{'form.file'}) {
                     83:         $r->print(&processPDF);
                     84:     } else { 
                     85:         # print upload form
                     86:         $r->print(&get_javascripts);
                     87:         $r->print(&get_uploadform);
                     88:     }
                     89: 
                     90:     #link to course-content
1.6       bisitz     91:     $r->print('<hr />'
                     92:              .'<p>'."\n"
1.5       bisitz     93:              .'<a href="/adm/navmaps">'."\n"
1.14    ! raeburn    94:              .&mt('Course Contents')."\n"
1.5       bisitz     95:              .'</a>'."\n"
                     96:              .'</p>'."\n"
                     97:     );
1.1       onken      98: 
1.2       onken      99:     #&dumpenv($r); #debug -> prints the environment
1.7       onken     100:     $r->print(&Apache::loncommon::end_page());
1.1       onken     101:     return OK;
1.2       onken     102: }
1.1       onken     103: 
                    104: 
                    105: sub checkpermission() {
                    106:     my $r = shift;
                    107:     if (! &LONCAPA::loncgi::check_cookie_and_load_env()) {
                    108:         my $result  = <<END
                    109: Content-type: text/html
                    110: 
                    111: <html>
1.2       onken     112:   <head>
                    113:     <title>
                    114:       Bad Cookie
                    115:     </title>
                    116:   </head>
                    117:   <body>
                    118:     Your cookie information is incorrect.
                    119:   </body>
1.1       onken     120: </html>
                    121: END
                    122: ;
                    123:         $r->print($result);
                    124:         return 0;
                    125:     } else {
                    126:         return 1;
                    127:     }
                    128: }
                    129: 
                    130: 
                    131: sub get_javascripts() {
1.2       onken     132:     
1.6       bisitz    133:     my $message = &mt('Please choose a PDF-File.');
1.1       onken     134: 
1.2       onken     135:     # simple test if the upload ends with ".pdf"
                    136:     # it's only for giving a message to the user
                    137:     my $result .= <<END
                    138:   <script type="text/javascript">
1.1       onken     139:     function checkFilename(form) {
                    140:         var fileExt = form.file.value;
                    141:         fileExt = fileExt.match(/[.]pdf\$/g);
                    142:         if(fileExt) {
                    143:             return true;
                    144:         }
1.2       onken     145:         alert("$message");
1.1       onken     146:         return false;
                    147:     }
1.2       onken     148:   </script>
1.1       onken     149: END
                    150: ;
                    151:     return $result; 
                    152: }
                    153: 
1.2       onken     154: 
1.1       onken     155: sub get_uploadform() {
1.4       onken     156:     
                    157:     my %lt = &Apache::lonlocal::texthash(
1.6       bisitz    158:                  'title'  => 'Upload a PDF Form with filled Form Fields', 
                    159:                  'chFile' => 'File',
                    160:                  'submit' => 'Upload',
1.4       onken     161:              );
                    162: 
1.5       bisitz    163:     my $result = 
                    164:         '<br />'
                    165:        .'<form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);">'
                    166:        .'<input type="hidden" name="type" value="upload" />'
                    167:        .&Apache::lonhtmlcommon::start_pick_box()
                    168:        .&Apache::lonhtmlcommon::row_headline()
                    169:        .'<h2>'.$lt{'title'}.'</h2>'
                    170:        .&Apache::lonhtmlcommon::row_closure()
                    171:        .&Apache::lonhtmlcommon::row_title($lt{'chFile'})
                    172:        .'<input type="file" name="file" id="filename" />'
                    173:        .&Apache::lonhtmlcommon::row_closure(1)
                    174:        .&Apache::lonhtmlcommon::end_pick_box()
1.13      bisitz    175:        .'<p>'
1.5       bisitz    176:        .'<input type="submit" name="Uploaded" value="'.$lt{'submit'}.'" />'
1.13      bisitz    177:        .'</p>'
1.5       bisitz    178:        .'</form>'
1.6       bisitz    179:        .'<br />';
1.5       bisitz    180: 
1.1       onken     181:   return $result;
                    182: }
                    183: 
                    184: sub processPDF {
1.2       onken     185:     my $result = ();  # message for Browser
                    186:     my @pdfdata = (); # answers from PDF-Forms
1.1       onken     187:     
1.2       onken     188:     @pdfdata = &get_pdf_data(); # get answers from PDF-Form
1.1       onken     189:     
                    190:     if (scalar @pdfdata) {    
1.2       onken     191:         &grade_pdf(@pdfdata);
1.1       onken     192:     } else {
1.6       bisitz    193:         $result .= '<p class="LC_error">'
                    194:                   .&mt("Can't find any valid PDF formfields.")
                    195:                   .'</p>';
1.1       onken     196:     }
                    197: }
                    198: 
                    199: sub get_pdf_data() {
                    200:     my @data = ();
1.2       onken     201:     my $pdf = CAM::PDF->new($env{'form.file'});
                    202: 
                    203:     my @formFields = $pdf->getFormFieldList(); #get names of formfields
1.1       onken     204:     
1.2       onken     205:     foreach my $field (@formFields) {
                    206: 	my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get formfield dictonary
1.1       onken     207: 
1.2       onken     208:         #
                    209:         # this is nessesary 'cause CAM::PDF has a problem with formfieldnames which include a
                    210:         # dot in fieldnames. So a fieldname like "i.am.aFormfield" will offer three fieldnames "i", "i.am" 
                    211:         # and "i.am.aFormfield". The fragmentary names keep no values and will be ignored.
                    212:         if($dict->{'V'}) {
                    213:             push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
                    214:         }
                    215:     } 
1.1       onken     216:     return @data;
                    217: }
                    218: 
                    219: sub grade_pdf {
                    220:     my $result = ();
                    221:     my @pdfdata = @_;
                    222:    
                    223:     my $meta = ();
                    224:     my %grades = ();
                    225:     my %problems = ();
                    226:         
                    227:     my $debug = ();
                    228: 
                    229:     $debug  .= "Found: ". scalar @pdfdata." Entries \n";
1.4       onken     230: 
1.1       onken     231:     foreach my $entry (sort(@pdfdata)) {
                    232:         if ($entry =~ /^meta.*/) {
1.2       onken     233:             $debug .= 'found: metadata -> '.$entry . "<br />";
                    234:             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
1.1       onken     235:             my ($domain, $user) = split('&', $value);
1.4       onken     236:             $user =~ s/(.*)\n/$1/; #TODO is that equals to chomp?
1.1       onken     237:             
                    238:             if($user ne $env{'user.name'} or  $domain ne $env{'user.domain'}) {
1.12      bisitz    239:                 return '<p class="LC_error">'
                    240:                       .&mt('Wrong username ([_1]) found in PDF file. Expected username: [_2]'
                    241:                           ,$user.':'.$domain
                    242:                           ,$env{'user.domain'}.':'.$env{'user.name'})
                    243:                       .'</p>';
1.1       onken     244:             }
                    245: 
                    246:         } elsif($entry =~ /^upload.*/)  {
                    247:             $debug .= 'found: a problem -> '.$entry;
1.2       onken     248:             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
1.1       onken     249:             my ($symb, $part, $type, $HWVAL) = split('&', $label);
                    250:             my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);  
                    251:             $value =~ s/(.*)\n/$1/; 
                    252: 
1.6       bisitz    253:             #filter incorrect radiobuttons (Bug in CABAReT Stage)
1.1       onken     254:             if($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
                    255:                 next;
                    256:             }
                    257:  
                    258:             my $submit = $part;
                    259:             $submit =~ s/part_(.*)/submit_$1/;
                    260:             if($problems{$symb.$part}) {
                    261:                  $problems{$symb.$part}{$HWVAL} = $value;
                    262:             } else {
                    263:                  $problems{$symb.$part} =  { 'resource' => $resource,
1.11      onken     264:                                         'symb' => $symb,
1.1       onken     265:                                         'submitted' => $part,
                    266:                                         $submit => 'Answer',
                    267:                                         $HWVAL => $value};
                    268:             }
                    269:         } else {
                    270:             $debug .= 'found: -> '.$entry;
                    271:             next;
                    272:         }
                    273:     }
1.4       onken     274:     #$result .= $debug;
1.1       onken     275: 
1.12      bisitz    276:     $result .= '<h2>'.&mt('Results of PDF Form problems').'</h2>';
                    277:     $result .= &Apache::loncommon::start_data_table()
                    278:               .&Apache::loncommon::start_data_table_header_row()
                    279:               .'<th>'.&mt('Problem Name').'</th>'
                    280:               .'<th>'.&mt('Grading').'</th>'
                    281:               .&Apache::loncommon::start_data_table_header_row()
                    282:               .&Apache::loncommon::end_data_table_header_row();
                    283: 
1.1       onken     284:     foreach my $key (sort (keys %problems)) {
                    285:         my %problem = %{$problems{$key}};
                    286:         my ($problemname, $grade) = &grade_problem(%problem);
1.4       onken     287: 
                    288:         $result .= &Apache::loncommon::start_data_table_row();
                    289:         $result .= "<td>$problemname</td><td class='";
1.8       onken     290:         if($grade eq "EXACT_ANS" || $grade eq "APPROX_ANS") {
1.4       onken     291:             $result .= "LC_answer_correct";
1.1       onken     292:         } else { 
1.4       onken     293:             $result .= "LC_answer_charged_try";
1.1       onken     294:         }
1.8       onken     295:         $grade = &parse_grade_answer($grade);
1.4       onken     296:         $result .= "'>$grade</span></td>";
                    297:         $result .= &Apache::loncommon::end_data_table_row();
                    298:     }
                    299:     $result .= &Apache::loncommon::end_data_table();
1.1       onken     300: 
                    301: 
                    302:     return $result;        
                    303: }
                    304: 
                    305: sub grade_problem {
                    306:     my %problem = @_;
1.7       onken     307:     my ($title, $part) = ();
1.1       onken     308: 
1.7       onken     309:     &Apache::loncommon::ssi_with_retries('/res/'.$problem{'resource'}, 5, %problem);
1.1       onken     310: 
1.7       onken     311:     $title = &Apache::lonnet::gettitle($problem{'symb'});    
                    312:     $part = $problem{submitted};
1.1       onken     313:     $part =~ s/part_(.*)/$1/;
1.7       onken     314:     unless($part eq '0') {
                    315:         #add information about part number
                    316:         $title .= " - Part $part";
                    317:     }
1.1       onken     318:  
                    319:     my %problemhash = &Apache::lonnet::restore($problem{'symb'});
                    320:     my $grade = $problemhash{"resource.$part.award"};
                    321: 
1.7       onken     322:     return ($title, $grade);    
1.1       onken     323: }
                    324: 
1.8       onken     325: sub parse_grade_answer {
                    326:     my ($shortcut) = @_;
                    327:      my %answerhash = ('EXACT_ANS' => &mt('You are correct.'),
1.10      onken     328:                        'APPROX_ANS' => &mt('You are correct.'),
1.8       onken     329:                        'INCORRECT' => &mt('You are incorrect'),
                    330:      );
                    331: 
                    332:     foreach my $key (keys %answerhash) {
                    333:         if($shortcut eq $key) {
                    334:             return $answerhash{$shortcut};
                    335:         }  
                    336:     }
                    337:     return &mt('See course contents for further information.');
                    338: 
                    339: }
                    340: 
                    341: 
1.1       onken     342: sub dumpenv  {
                    343:     my $r = shift;
                    344: 
                    345:     $r->print ("<br />-------------------<br />");
                    346:     foreach my $key (sort (keys %env)) {
                    347:         $r->print ("<br />$key -> $env{$key}");
                    348:     }
                    349:     $r->print ("<br />-------------------<br />");
                    350:     $r->print ("<br />-------------------<br />");
                    351:     foreach my $key (sort (keys %ENV)) {
                    352:         $r->print ("<br />$key -> $ENV{$key}");
                    353:     }
                    354:     $r->print ("<br />-------------------<br />");
                    355:     
                    356: }	
                    357: 
                    358: 1;
                    359: __END__
                    360: 

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