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

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

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