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

1.1       onken       1: # The LearningOnline Network with CAPA
                      2: # Publication Handler
                      3: #
1.2     ! onken       4: # $Id: lonpdfupload.pm,v 1.1 2008/09/09 13:56:44 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);
                     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();
        !            68:     $r->print(&Apache::loncommon::start_page('Upload-PDF-Form'));
        !            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
        !            83:     $r->print("    <br />\n    <a href='/adm/navmaps'>\n      ".&mt("Navigate Contents")."\n    </a>\n    <br />");
1.1       onken      84: 
1.2     ! onken      85:     #&dumpenv($r); #debug -> prints the environment
        !            86:     $r->print("  </body> \n</html>\n");
1.1       onken      87:     return OK;
1.2     ! onken      88: }
1.1       onken      89: 
                     90: 
                     91: sub checkpermission() {
                     92:     my $r = shift;
                     93:     if (! &LONCAPA::loncgi::check_cookie_and_load_env()) {
                     94:         my $result  = <<END
                     95: Content-type: text/html
                     96: 
                     97: <html>
1.2     ! onken      98:   <head>
        !            99:     <title>
        !           100:       Bad Cookie
        !           101:     </title>
        !           102:   </head>
        !           103:   <body>
        !           104:     Your cookie information is incorrect.
        !           105:   </body>
1.1       onken     106: </html>
                    107: END
                    108: ;
                    109:         $r->print($result);
                    110:         return 0;
                    111:     } else {
                    112:         return 1;
                    113:     }
                    114: }
                    115: 
                    116: 
                    117: sub get_javascripts() {
1.2     ! onken     118:     
        !           119:     my $message = &mt('Please choose a PDF-File');
1.1       onken     120: 
1.2     ! onken     121:     # simple test if the upload ends with ".pdf"
        !           122:     # it's only for giving a message to the user
        !           123:     my $result .= <<END
        !           124:   <script type="text/javascript">
1.1       onken     125:     function checkFilename(form) {
                    126:         var fileExt = form.file.value;
                    127:         fileExt = fileExt.match(/[.]pdf\$/g);
                    128:         if(fileExt) {
                    129:             return true;
                    130:         }
1.2     ! onken     131:         alert("$message");
1.1       onken     132:         return false;
                    133:     }
1.2     ! onken     134:   </script>
1.1       onken     135: END
                    136: ;
                    137:     return $result; 
                    138: }
                    139: 
1.2     ! onken     140: 
1.1       onken     141: sub get_uploadform() {
                    142:     my $result = <<END
                    143:     <p height='25'> 
                    144:     </p>
                    145:     <form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);">
                    146:       <input type="hidden" name="type" value="upload">
                    147:       <div align="center">
                    148:         <table bgcolor="#000000" width="450" cellspacing="0" cellpadding="0" border="0">
                    149:           <tr>
                    150:             <td>
                    151:               <table cellspacing="1" cellpadding="2" border="0" width="100%">
                    152:                 <tr>
                    153:                   <td colspan="2" bgcolor="#99EEEE">
                    154:                     <b>PDF-Formular einsenden</b>
                    155:                   </td>
                    156:                 </tr>
                    157:                 <tr>
                    158:                   <td bgcolor="#F8F8F8">
                    159:                       Datei ausw&auml;hlen
                    160:                   </td>
                    161:                   <td bgcolor="#F8F8F8">
                    162:                     <input type="file" name="file" id="filename">
                    163:                   </td>
                    164:                 </tr>
                    165:                 <tr>
                    166:                   <td bgcolor="#F8F8F8" colspan="2" align="right" style="margin-right: 30px;">
                    167:                     <input type="submit" name="Uploaded" value="Absenden" >
                    168:                   </td>
                    169:                 </tr>
                    170:                 </table>
                    171:               </td>
                    172:            </tr>
                    173:         </table>
                    174:       </div>
                    175:     </form>    
                    176: END
                    177: ;
                    178:   return $result;
                    179: }
                    180: 
                    181: sub processPDF {
1.2     ! onken     182:     my $result = ();  # message for Browser
        !           183:     my @pdfdata = (); # answers from PDF-Forms
1.1       onken     184:     
1.2     ! onken     185:     @pdfdata = &get_pdf_data(); # get answers from PDF-Form
1.1       onken     186:     
                    187:     if (scalar @pdfdata) {    
1.2     ! onken     188:         &grade_pdf(@pdfdata);
1.1       onken     189:     } else {
1.2     ! onken     190:         $result .= "<h2>".&mt("Can't find any valid PDF-formfields")."</h2>";
1.1       onken     191:     }
                    192: }
                    193: 
                    194: sub get_pdf_data() {
                    195:     my @data = ();
1.2     ! onken     196:     my $pdf = CAM::PDF->new($env{'form.file'});
        !           197: 
        !           198:     my @formFields = $pdf->getFormFieldList(); #get names of formfields
1.1       onken     199:     
1.2     ! onken     200:     foreach my $field (@formFields) {
        !           201: 	my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get formfield dictonary
1.1       onken     202: 
1.2     ! onken     203:         #
        !           204:         # this is nessesary 'cause CAM::PDF has a problem with formfieldnames which include a
        !           205:         # dot in fieldnames. So a fieldname like "i.am.aFormfield" will offer three fieldnames "i", "i.am" 
        !           206:         # and "i.am.aFormfield". The fragmentary names keep no values and will be ignored.
        !           207:         if($dict->{'V'}) {
        !           208:             push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
        !           209:         }
        !           210:     } 
1.1       onken     211:     return @data;
                    212: }
                    213: 
                    214: sub grade_pdf {
                    215:     my $result = ();
                    216:     my @pdfdata = @_;
                    217:    
                    218:     my $meta = ();
                    219:     my %grades = ();
                    220:     my %problems = ();
                    221:         
                    222:     my $debug = ();
                    223: 
                    224:     $debug  .= "Found: ". scalar @pdfdata." Entries \n";
                    225:     $result .= "<table width='80%'>\n";
                    226:     foreach my $entry (sort(@pdfdata)) {
                    227:         if ($entry =~ /^meta.*/) {
1.2     ! onken     228:             $debug .= 'found: metadata -> '.$entry . "<br />";
        !           229:             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
1.1       onken     230:             my ($domain, $user) = split('&', $value);
1.2     ! onken     231:             $user =~ s/(.*)\n/$1/; #TODO find an other way
1.1       onken     232:             
                    233:             if($user ne $env{'user.name'} or  $domain ne $env{'user.domain'}) {
                    234:                 return "<pre>".&mt('Wrong username in PDF-File').": $user $domain -> $env{'user.domain'} $env{'user.name'} </pre>";    
                    235:             }
                    236: 
                    237:         } elsif($entry =~ /^upload.*/)  {
                    238:             $debug .= 'found: a problem -> '.$entry;
1.2     ! onken     239:             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
1.1       onken     240:             my ($symb, $part, $type, $HWVAL) = split('&', $label);
                    241:             my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);  
                    242:             $value =~ s/(.*)\n/$1/; 
                    243: 
                    244:             #fehlerhafte Radiobuttons rausfiltern (Bug in CABAReT Stage)
                    245:             if($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
                    246:                 next;
                    247:             }
                    248:  
                    249:             my $submit = $part;
                    250:             $submit =~ s/part_(.*)/submit_$1/;
                    251:             if($problems{$symb.$part}) {
                    252:                  $problems{$symb.$part}{$HWVAL} = $value;
                    253:             } else {
                    254:                  $problems{$symb.$part} =  { 'resource' => $resource,
                    255:                                         'symb' => $symb,
                    256:                                         'submitted' => $part,
                    257:                                         $submit => 'Answer',
                    258:                                         $HWVAL => $value};
                    259:             }
                    260:         } else {
                    261:             $debug .= 'found: -> '.$entry;
                    262:             next;
                    263:         }
                    264:     }
1.2     ! onken     265:     $result .= $debug;
1.1       onken     266: 
                    267:     foreach my $key (sort (keys %problems)) {
                    268:         my %problem = %{$problems{$key}};
                    269:         my ($problemname, $grade) = &grade_problem(%problem);
                    270:         $result .= "<tr style='background-color: #EEF5F5;'><td>$problemname</td><td style='background-color: ";
                    271:         if($grade eq "EXACT_ANS") {
                    272:             $result .= "#DDFFDD";
                    273:         } else { 
                    274:             $result .= "#DD5555";
                    275:         }
                    276:         $result .= "'>$grade</td></tr>";
                    277: 
                    278:     }
                    279:     $result .= "\n</table>";
                    280: 
                    281:     return $result;        
                    282: }
                    283: 
                    284: sub grade_problem {
                    285:     my %problem = @_;
                    286: 
                    287:     my ($content) =  &Apache::loncommon::ssi_with_retries('/res/'.
                    288:             $problem{'resource'}, 5, %problem);
                    289: 
                    290:     $content =~ s/.*class="LC_current_location".*>(.*)<\/td>.*/$1/g;
                    291:     $content = $1;
                    292: 
                    293:     my $part = $problem{submitted};
                    294:     $part =~ s/part_(.*)/$1/;
                    295:     $content .= " - Part $part";
                    296:  
                    297:     my %problemhash = &Apache::lonnet::restore($problem{'symb'});
                    298:     my $grade = $problemhash{"resource.$part.award"};
                    299: 
                    300:     return ($content, $grade);    
                    301: }
                    302: 
                    303: sub dumpenv  {
                    304:     my $r = shift;
                    305: 
                    306:     $r->print ("<br />-------------------<br />");
                    307:     foreach my $key (sort (keys %env)) {
                    308:         $r->print ("<br />$key -> $env{$key}");
                    309:     }
                    310:     $r->print ("<br />-------------------<br />");
                    311:     $r->print ("<br />-------------------<br />");
                    312:     foreach my $key (sort (keys %ENV)) {
                    313:         $r->print ("<br />$key -> $ENV{$key}");
                    314:     }
                    315:     $r->print ("<br />-------------------<br />");
                    316:     
                    317: }	
                    318: 
                    319: 1;
                    320: __END__
                    321: 

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