Return to lonpdfupload.pm CVS log

Up to [LON-CAPA] / loncom / interface

- Making pdfupload more like the rest of LON-CAPA.
  - Authz handler: lonacc
  - path: /adm/pdfupload
  - remove "use package" for packages which are not actually used
  - use routine in loncommon.pm to generate HTTP header.

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