[BACK]Return to lonpdfupload.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / interface

Diff for /loncom/interface/lonpdfupload.pm between versions 1.2 and 1.24

version 1.2, 2009/04/03 15:40:17 version 1.24, 2014/12/12 14:21:22
Line 1 Line 1
 # The LearningOnline Network with CAPA  # The LearningOnline Network with CAPA
 # Publication Handler  # PDF Form Upload Handler
 #  #
 # $Id$  # $Id$
 #  #
Line 29  package Apache::lonpdfupload; Line 29  package Apache::lonpdfupload;
   
 use lib '/home/httpd/lib/perl';  use lib '/home/httpd/lib/perl';
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
 use LONCAPA;  
 use LONCAPA::loncgi;  
 use File::Path;  
 use File::Basename;  
 use File::Copy;  
 use IO::File;  
 use Image::Magick;  
 use Apache::lonacc;  
 use Apache::lonxml;  
 use Apache::lonhtmlcommon();  
 use Apache::lonnet;  use Apache::lonnet;
   use Apache::lonhtmlcommon();
 use Apache::loncommon();  use Apache::loncommon();
   use Apache::lonnavmaps();
 use Apache::lonlocal;  use Apache::lonlocal;
 use Apache::lonmsg();  use File::MMagic;
 use Apache::lonhomework;  
 use LONCAPA::Enrollment;  
 use LONCAPA::Configuration;  
 use CAM::PDF;  use CAM::PDF;
   use LONCAPA qw(:DEFAULT :match);
   
 use strict;  use strict;
   
 sub handler() {  sub handler() {
     my $r = shift;      my $r = shift;
       &Apache::loncommon::content_type($r,'text/html');
     # check user permissions       $r->send_http_header;
     if(!&checkpermission($r)) {      return OK if $r->header_only;
         # stop processing   
         return OK;      #  Needs to be in a course
       if (!$env{'request.course.fn'}) {
           # Not in a course
           $env{'user.error.msg'}="/adm/pdfupload:bre:0:0:Cannot upload PDF forms unless in a course";
           return HTTP_NOT_ACCEPTABLE;
     }      }
   
     $Apache::lonxml::request=$r;      # Breadcrumbs
     $Apache::lonxml::debug=$env{'user.debug'};      my $brcrum = [{'href' => '/adm/pdfupload',
                      'text' => 'Upload PDF Form'}];
     $env{'request.uri'}=$r->uri;      if ($env{'form.Uploaded'} && $env{'form.file'}) {
     $r->content_type('text/html');          push(@{$brcrum},{'href'  => '',
     $r->send_http_header();                           'text'  => 'PDF upload result'});
     $r->print(&Apache::loncommon::start_page('Upload-PDF-Form'));      }
   
     #load post data into environment      $r->print(&Apache::loncommon::start_page('Upload PDF Form',
     &Apache::lonacc::get_posted_cgi($r);                                               undef,
                                                {'bread_crumbs' => $brcrum,})
       );
   
       if ($env{'request.course.id'}) {
           my $permission = $env{'course.'.$env{'request.course.id'}.'.canuse_pdfforms'};
           if ($permission eq '') {
               my %domdefs = &Apache::lonnet::get_domain_defaults($env{'course.'.$env{'request.course.id'}.'.domain'});
               $permission = $domdefs{'canuse_pdfforms'};
           }
           unless ($permission) {
               $r->print('<p class="LC_warning">'.
                         &mt('Upload of PDF forms is not permitted for this course.').
                         '</p>'.
                         &Apache::loncommon::end_page());
               return OK;
           }
       } else {
           $r->print('<p class="LC_warning">'.
                     &mt('Could not determine identity of this course.').' '.
                     &mt('You may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
                     '</p>'.
                     &Apache::loncommon::end_page());
           return OK;
       }
   
     # if a file was upload      # if a file was upload
     if($env{'form.Uploaded'} && $env{'form.file'}) {      if($env{'form.Uploaded'} && $env{'form.file'}) {
         $r->print(&processPDF);          my $mm = new File::MMagic;
           my $mime_type = $mm->checktype_contents($env{'form.file'});
           if ($mime_type eq 'application/pdf') {
               $r->print(&processPDF);
           } else {
               $r->print('<p class="LC_error">'
                        .&mt("The uploaded file does not appear to be a PDF file.")
                        .'</p>');
           }
     } else {       } else { 
         # print upload form          # print upload form
         $r->print(&get_javascripts);          $r->print(&get_javascripts);
Line 80  sub handler() { Line 106  sub handler() {
     }      }
   
     #link to course-content      #link to course-content
     $r->print("    <br />\n    <a href='/adm/navmaps'>\n      ".&mt("Navigate Contents")."\n    </a>\n    <br />");      $r->print('<hr />'
                .'<p>'."\n"
                .'<a href="/adm/navmaps">'."\n"
                .&mt('Course Contents')."\n"
                .'</a>'."\n"
                .'</p>'."\n"
       );
   
     #&dumpenv($r); #debug -> prints the environment      #&dumpenv($r); #debug -> prints the environment
     $r->print("  </body> \n</html>\n");      $r->print(&Apache::loncommon::end_page());
     return OK;      return OK;
 }  }
   
   
 sub checkpermission() {  
     my $r = shift;  
     if (! &LONCAPA::loncgi::check_cookie_and_load_env()) {  
         my $result  = <<END  
 Content-type: text/html  
   
 <html>  
   <head>  
     <title>  
       Bad Cookie  
     </title>  
   </head>  
   <body>  
     Your cookie information is incorrect.  
   </body>  
 </html>  
 END  
 ;  
         $r->print($result);  
         return 0;  
     } else {  
         return 1;  
     }  
 }  
   
   
 sub get_javascripts() {  sub get_javascripts() {
           
     my $message = &mt('Please choose a PDF-File');      my $message = &mt('Please choose a PDF-File.');
   
     # simple test if the upload ends with ".pdf"      # simple test if the upload ends with ".pdf"
     # it's only for giving a message to the user      # it's only for giving a message to the user
     my $result .= <<END      my $result .= <<END
   <script type="text/javascript">    <script type="text/javascript">
   // <![CDATA[
     function checkFilename(form) {      function checkFilename(form) {
         var fileExt = form.file.value;          var fileExt = form.file.value;
         fileExt = fileExt.match(/[.]pdf\$/g);          fileExt = fileExt.match(/[.]pdf\$/gi);
         if(fileExt) {          if(fileExt) {
             return true;              return true;
         }          }
         alert("$message");          alert("$message");
         return false;          return false;
     }      }
   // ]]>
   </script>    </script>
 END  END
 ;  ;
Line 139  END Line 146  END
   
   
 sub get_uploadform() {  sub get_uploadform() {
     my $result = <<END      
     <p height='25'>       my %lt = &Apache::lonlocal::texthash(
     </p>                   'title'  => 'Upload a PDF Form with filled Form Fields', 
     <form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);">                   'chFile' => 'File',
       <input type="hidden" name="type" value="upload">                   'submit' => 'Upload',
       <div align="center">               );
         <table bgcolor="#000000" width="450" cellspacing="0" cellpadding="0" border="0">  
           <tr>      my $result = 
             <td>          '<br />'
               <table cellspacing="1" cellpadding="2" border="0" width="100%">         .'<form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);" action="">'
                 <tr>         .&Apache::lonhtmlcommon::start_pick_box()
                   <td colspan="2" bgcolor="#99EEEE">         .&Apache::lonhtmlcommon::row_headline()
                     <b>PDF-Formular einsenden</b>         .'<h2>'.$lt{'title'}.'</h2>'
                   </td>         .&Apache::lonhtmlcommon::row_closure()
                 </tr>         .&Apache::lonhtmlcommon::row_title($lt{'chFile'})
                 <tr>         .'<input type="file" name="file" id="filename" />'
                   <td bgcolor="#F8F8F8">         .&Apache::lonhtmlcommon::row_closure(1)
                       Datei ausw&auml;hlen         .&Apache::lonhtmlcommon::end_pick_box()
                   </td>         .'<p>'
                   <td bgcolor="#F8F8F8">         .'<input type="submit" name="Uploaded" value="'.$lt{'submit'}.'" />'
                     <input type="file" name="file" id="filename">         .'</p>'
                   </td>         .'</form>'
                 </tr>         .'<br />';
                 <tr>  
                   <td bgcolor="#F8F8F8" colspan="2" align="right" style="margin-right: 30px;">  
                     <input type="submit" name="Uploaded" value="Absenden" >  
                   </td>  
                 </tr>  
                 </table>  
               </td>  
            </tr>  
         </table>  
       </div>  
     </form>      
 END  
 ;  
   return $result;    return $result;
 }  }
   
Line 187  sub processPDF { Line 182  sub processPDF {
     if (scalar @pdfdata) {          if (scalar @pdfdata) {    
         &grade_pdf(@pdfdata);          &grade_pdf(@pdfdata);
     } else {      } else {
         $result .= "<h2>".&mt("Can't find any valid PDF-formfields")."</h2>";          $result .= '<p class="LC_error">'
                     .&mt("Can't find any valid PDF form fields.")
                     .'</p>';
     }      }
 }  }
   
Line 195  sub get_pdf_data() { Line 192  sub get_pdf_data() {
     my @data = ();      my @data = ();
     my $pdf = CAM::PDF->new($env{'form.file'});      my $pdf = CAM::PDF->new($env{'form.file'});
   
     my @formFields = $pdf->getFormFieldList(); #get names of formfields      if($pdf) {
               my @formFields = $pdf->getFormFieldList(); #get names of form fields
     foreach my $field (@formFields) {  
  my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get formfield dictonary  
   
         #          foreach my $field (@formFields) {
         # this is nessesary 'cause CAM::PDF has a problem with formfieldnames which include a              my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get form field dictonary
         # dot in fieldnames. So a fieldname like "i.am.aFormfield" will offer three fieldnames "i", "i.am"   
         # and "i.am.aFormfield". The fragmentary names keep no values and will be ignored.              # this is necessary because CAM::PDF has a problem with form fieldnames which include a
         if($dict->{'V'}) {              # dot in fieldnames. So a fieldname like "i.am.aFormfield" will offer three fieldnames
             push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value              # "i", "i.am" and "i.am.aFormfield". The fragmentary names keep no values and will be ignored.
               if($dict->{'V'}) {
                   push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
               }
         }          }
     }       }
     return @data;      return @data;
 }  }
   
 sub grade_pdf {  sub grade_pdf {
     my $result = ();  
     my @pdfdata = @_;      my @pdfdata = @_;
          my ($result,$meta,%grades,%problems,%foreigncourse,$debug);
     my $meta = ();  
     my %grades = ();  
     my %problems = ();  
           
     my $debug = ();  
   
       my $navmap = Apache::lonnavmaps::navmap->new();
       if (!defined($navmap)) {
           $result = '<h3>'.&mt('Verification of PDF form items failed').'</h3>'.
                     '<div class="LC_error">'.
                     &mt('Unable to retrieve information about course contents').' '.
                     &mt('You may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
                     '</div>';
           return $result;
       }
       my %restitles;
       foreach my $res ($navmap->retrieveResources()) {
           my $symb = $res->symb; 
           $restitles{$symb} = $res->compTitle();
       }
      
     $debug  .= "Found: ". scalar @pdfdata." Entries \n";      $debug  .= "Found: ". scalar @pdfdata." Entries \n";
     $result .= "<table width='80%'>\n";  
     foreach my $entry (sort(@pdfdata)) {      foreach my $entry (sort(@pdfdata)) {
         if ($entry =~ /^meta.*/) {          if ($entry =~ /^meta.*/) {
             $debug .= 'found: metadata -> '.$entry . "<br />";              $debug .= 'found: metadata -> '.$entry . "<br />";
             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);              my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
             my ($domain, $user) = split('&', $value);              my ($domain, $user) = split('&', $value);
             $user =~ s/(.*)\n/$1/; #TODO find an other way              $user =~ s/(.*)\n/$1/; #TODO is that equals to chomp?
               
             if($user ne $env{'user.name'} or  $domain ne $env{'user.domain'}) {              if($user ne $env{'user.name'} or  $domain ne $env{'user.domain'}) {
                 return "<pre>".&mt('Wrong username in PDF-File').": $user $domain -> $env{'user.domain'} $env{'user.name'} </pre>";                      return '<p class="LC_error">'
                         .&mt('Wrong username ([_1]) found in PDF file. Expected username: [_2]'
                             ,$user.':'.$domain
                             ,$env{'user.domain'}.':'.$env{'user.name'})
                         .'</p>';
             }              }
   
         } elsif($entry =~ /^upload.*/)  {          } elsif ($entry =~ /^upload.*/)  {
             $debug .= 'found: a problem -> '.$entry;              $debug .= 'found: a problem -> '.$entry;
             my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);              my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
             my ($symb, $part, $type, $HWVAL) = split('&', $label);              my ($symb, $part, $type, $HWVAL) = split('&', $label);
             my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);                my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
               if ($map =~ m{^uploaded/($match_domain)/($match_courseid)/default(_?\d*)\.(page|sequence)}) {
                   my $mapcid = $1.'_'.$2;
                   if ($mapcid ne $env{'request.course.id'}) {
                       push(@{$foreigncourse{$mapcid}},$symb);
                   }
               }
               next unless (exists($restitles{$symb}));
             $value =~ s/(.*)\n/$1/;               $value =~ s/(.*)\n/$1/; 
   
             #fehlerhafte Radiobuttons rausfiltern (Bug in CABAReT Stage)              #filter incorrect radiobuttons (Bug in CABAReT Stage)
             if($type eq 'radiobuttonresponse' && $value eq 'Off' ) {              if ($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
                 next;                  next;
             }              }
     
             my $submit = $part;              my $submit = $part;
             $submit =~ s/part_(.*)/submit_$1/;              $submit =~ s/part_(.*)/submit_$1/;
             if($problems{$symb.$part}) {              if ($problems{$symb.$part}) {
                  $problems{$symb.$part}{$HWVAL} = $value;                   $problems{$symb.$part}{$HWVAL} = $value;
             } else {              } else {
                  $problems{$symb.$part} =  { 'resource' => $resource,                   $problems{$symb.$part} =  { 'resource' => $resource,
Line 262  sub grade_pdf { Line 279  sub grade_pdf {
             next;              next;
         }          }
     }      }
     $result .= $debug;      #$result .= $debug;
   
     foreach my $key (sort (keys %problems)) {      $result .= '<h3>'.&mt('Result of PDF Form upload').'</h3>';
         my %problem = %{$problems{$key}};  
         my ($problemname, $grade) = &grade_problem(%problem);  
         $result .= "<tr style='background-color: #EEF5F5;'><td>$problemname</td><td style='background-color: ";  
         if($grade eq "EXACT_ANS") {  
             $result .= "#DDFFDD";  
         } else {   
             $result .= "#DD5555";  
         }  
         $result .= "'>$grade</td></tr>";  
   
       if (keys(%problems) > 0) {
           $result .= &Apache::loncommon::start_data_table()
                     .&Apache::loncommon::start_data_table_header_row()
                     .'<th>'.&mt('Problem Name').'</th>'
                     .'<th>'.&mt('Grading').'</th>'
                     .&Apache::loncommon::start_data_table_header_row()
                     .&Apache::loncommon::end_data_table_header_row();
   
           foreach my $key (sort(keys(%problems))) {
               my %problem = %{$problems{$key}};
               my ($problemname, $grade) = &grade_problem(%problem);
   
               $result .= &Apache::loncommon::start_data_table_row();
               $result .= '<td><a href="/res/'.$problem{'resource'}.
                          '?symb='.
                          &HTML::Entities::encode($problem{'symb'},'"&<>').
                          '">'.$problemname.'</a></td><td><span class="';
               if ($grade eq "EXACT_ANS" || $grade eq "APPROX_ANS") {
                   $result .= 'LC_answer_correct';
               } elsif ($grade eq "DRAFT") {
                   $result .= 'LC_answer_not_charged_try';
               } else {
                   $result .= 'LC_answer_charged_try';
               }
               $result .= '">';
               $grade = &parse_grade_answer($grade);
               $result .= $grade.'</span></td>';
               $result .= &Apache::loncommon::end_data_table_row();
           }
           $result .= &Apache::loncommon::end_data_table();
       } else {
           $result .= '<p class="LC_warning">'.
                      &mt('As no gradable form items were found, no submissions have been recorded.').
                      '</p>';
       }
       if (keys(%foreigncourse)) {
           my ($numother,$othercrsmsg);
           foreach my $cid (sort(keys(%foreigncourse))) {
               my %coursehash = &Apache::lonnet::coursedescription($cid,
                                                             {'one_time' => 1});
               if (ref($foreigncourse{$cid}) eq 'ARRAY') {
                   if ($numother) {
                       $othercrsmsg .= '</li><li>';
                   }
                   $othercrsmsg .= '<b>'.$coursehash{'description'}.'</b><ul>'."\n";
                   foreach my $symb (@{$foreigncourse{$cid}}) {
                       my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
                       $othercrsmsg .= '<li>'.$resource.'</li>';
                   }
                   $othercrsmsg .= '</ul>';
                   $numother ++;
               }
           }
           if ($numother) {
               $result .= '<div class="LC_warning">';
               if ($numother > 1) {
                   $result .= &mt('Your uploaded PDF form contained the following resource(s) from [_1] different courses:','<b>'.$numother.'</b>')."\n".'<ul><li>'.
                              $othercrsmsg.'</li></ul>';
               } else {
                   $result .= &mt('Your uploaded PDF form contained the following resource(s) from a different course:').' '.$othercrsmsg.
                              &mt('Did you download the PDF form from another course and upload it to the wrong course?'); 
               }
               $result .= '</div>';
           }
     }      }
     $result .= "\n</table>";  
   
     return $result;              return $result;
 }  }
   
 sub grade_problem {  sub grade_problem {
     my %problem = @_;      my %problem = @_;
       my ($title, $part) = ();
   
     my ($content) =  &Apache::loncommon::ssi_with_retries('/res/'.      &Apache::loncommon::ssi_with_retries('/res/'.$problem{'resource'}, 5, %problem);
             $problem{'resource'}, 5, %problem);  
   
     $content =~ s/.*class="LC_current_location".*>(.*)<\/td>.*/$1/g;  
     $content = $1;  
   
     my $part = $problem{submitted};      $title = &Apache::lonnet::gettitle($problem{'symb'});    
       $part = $problem{submitted};
     $part =~ s/part_(.*)/$1/;      $part =~ s/part_(.*)/$1/;
     $content .= " - Part $part";      unless($part eq '0') {
           #add information about part number
           $title .= " - Part $part";
       }
     
     my %problemhash = &Apache::lonnet::restore($problem{'symb'});      my %problemhash = &Apache::lonnet::restore($problem{'symb'});
     my $grade = $problemhash{"resource.$part.award"};      my $grade = $problemhash{"resource.$part.award"};
   
     return ($content, $grade);          return ($title, $grade);    
   }
   
   sub parse_grade_answer {
       my ($shortcut) = @_;
        my %answerhash = ('EXACT_ANS' => &mt('You are correct.'),
                          'APPROX_ANS' => &mt('You are correct.'),
                          'INCORRECT' => &mt('You are incorrect'),
                          'DRAFT' => &mt('Copy saved but not submitted.'),
        );
   
       foreach my $key (keys(%answerhash)) {
           if($shortcut eq $key) {
               return $answerhash{$shortcut};
           }  
       }
       return &mt('See course contents for further information.');
   
 }  }
   
   
 sub dumpenv  {  sub dumpenv  {
     my $r = shift;      my $r = shift;
   
     $r->print ("<br />-------------------<br />");      $r->print ("<br />-------------------<br />");
     foreach my $key (sort (keys %env)) {      foreach my $key (sort(keys(%env))) {
         $r->print ("<br />$key -> $env{$key}");          $r->print ("<br />$key -> $env{$key}");
     }      }
     $r->print ("<br />-------------------<br />");      $r->print ("<br />-------------------<br />");
     $r->print ("<br />-------------------<br />");      $r->print ("<br />-------------------<br />");
     foreach my $key (sort (keys %ENV)) {      foreach my $key (sort(keys(%ENV))) {
         $r->print ("<br />$key -> $ENV{$key}");          $r->print ("<br />$key -> $ENV{$key}");
     }      }
     $r->print ("<br />-------------------<br />");      $r->print ("<br />-------------------<br />");
Removed from v.1.2  
changed lines
  Added in v.1.24

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