--- loncom/interface/lonpdfupload.pm 2009/06/17 13:00:38 1.13
+++ loncom/interface/lonpdfupload.pm 2014/12/12 14:21:22 1.24
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# PDF Form Upload Handler
#
-# $Id: lonpdfupload.pm,v 1.13 2009/06/17 13:00:38 bisitz Exp $
+# $Id: lonpdfupload.pm,v 1.24 2014/12/12 14:21:22 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -29,58 +29,76 @@ package Apache::lonpdfupload;
use lib '/home/httpd/lib/perl';
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::lonhtmlcommon();
use Apache::loncommon();
+use Apache::lonnavmaps();
use Apache::lonlocal;
-use Apache::lonmsg();
-use Apache::lonhomework;
-use LONCAPA::Enrollment;
-use LONCAPA::Configuration;
+use File::MMagic;
use CAM::PDF;
+use LONCAPA qw(:DEFAULT :match);
use strict;
sub handler() {
my $r = shift;
-
- # check user permissions
- if(!&checkpermission($r)) {
- # stop processing
- return OK;
+ &Apache::loncommon::content_type($r,'text/html');
+ $r->send_http_header;
+ return OK if $r->header_only;
+
+ # 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;
- $Apache::lonxml::debug=$env{'user.debug'};
-
- $env{'request.uri'}=$r->uri;
- $r->content_type('text/html');
- $r->send_http_header();
-
# Breadcrumbs
- my $brcrum = [{'href' => '/pdfupload',
+ my $brcrum = [{'href' => '/adm/pdfupload',
'text' => 'Upload PDF Form'}];
+ if ($env{'form.Uploaded'} && $env{'form.file'}) {
+ push(@{$brcrum},{'href' => '',
+ 'text' => 'PDF upload result'});
+ }
$r->print(&Apache::loncommon::start_page('Upload PDF Form',
undef,
{'bread_crumbs' => $brcrum,})
);
- #load post data into environment
- &Apache::lonacc::get_posted_cgi($r);
+ 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($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 {
# print upload form
$r->print(&get_javascripts);
@@ -91,7 +109,7 @@ sub handler() {
$r->print('<hr />'
.'<p>'."\n"
.'<a href="/adm/navmaps">'."\n"
- .&mt("Navigate Contents")."\n"
+ .&mt('Course Contents')."\n"
.'</a>'."\n"
.'</p>'."\n"
);
@@ -101,33 +119,6 @@ sub handler() {
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() {
my $message = &mt('Please choose a PDF-File.');
@@ -136,15 +127,17 @@ sub get_javascripts() {
# it's only for giving a message to the user
my $result .= <<END
<script type="text/javascript">
+// <![CDATA[
function checkFilename(form) {
var fileExt = form.file.value;
- fileExt = fileExt.match(/[.]pdf\$/g);
+ fileExt = fileExt.match(/[.]pdf\$/gi);
if(fileExt) {
return true;
}
alert("$message");
return false;
}
+// ]]>
</script>
END
;
@@ -162,8 +155,7 @@ sub get_uploadform() {
my $result =
'<br />'
- .'<form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);">'
- .'<input type="hidden" name="type" value="upload" />'
+ .'<form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);" action="">'
.&Apache::lonhtmlcommon::start_pick_box()
.&Apache::lonhtmlcommon::row_headline()
.'<h2>'.$lt{'title'}.'</h2>'
@@ -191,7 +183,7 @@ sub processPDF {
&grade_pdf(@pdfdata);
} else {
$result .= '<p class="LC_error">'
- .&mt("Can't find any valid PDF formfields.")
+ .&mt("Can't find any valid PDF form fields.")
.'</p>';
}
}
@@ -200,32 +192,42 @@ sub get_pdf_data() {
my @data = ();
my $pdf = CAM::PDF->new($env{'form.file'});
- my @formFields = $pdf->getFormFieldList(); #get names of formfields
-
- foreach my $field (@formFields) {
- my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get formfield dictonary
+ if($pdf) {
+ my @formFields = $pdf->getFormFieldList(); #get names of form fields
- #
- # this is nessesary 'cause CAM::PDF has a problem with formfieldnames which include a
- # 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.
- if($dict->{'V'}) {
- push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
+ foreach my $field (@formFields) {
+ my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get form field dictonary
+
+ # this is necessary because CAM::PDF has a problem with form fieldnames which include a
+ # 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.
+ if($dict->{'V'}) {
+ push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
+ }
}
- }
+ }
return @data;
}
sub grade_pdf {
- my $result = ();
my @pdfdata = @_;
-
- my $meta = ();
- my %grades = ();
- my %problems = ();
-
- my $debug = ();
+ my ($result,$meta,%grades,%problems,%foreigncourse,$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";
foreach my $entry (sort(@pdfdata)) {
@@ -234,7 +236,6 @@ sub grade_pdf {
my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
my ($domain, $user) = split('&', $value);
$user =~ s/(.*)\n/$1/; #TODO is that equals to chomp?
-
if($user ne $env{'user.name'} or $domain ne $env{'user.domain'}) {
return '<p class="LC_error">'
.&mt('Wrong username ([_1]) found in PDF file. Expected username: [_2]'
@@ -243,21 +244,28 @@ sub grade_pdf {
.'</p>';
}
- } elsif($entry =~ /^upload.*/) {
+ } elsif ($entry =~ /^upload.*/) {
$debug .= 'found: a problem -> '.$entry;
my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
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/;
#filter incorrect radiobuttons (Bug in CABAReT Stage)
- if($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
+ if ($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
next;
}
my $submit = $part;
$submit =~ s/part_(.*)/submit_$1/;
- if($problems{$symb.$part}) {
+ if ($problems{$symb.$part}) {
$problems{$symb.$part}{$HWVAL} = $value;
} else {
$problems{$symb.$part} = { 'resource' => $resource,
@@ -273,33 +281,75 @@ sub grade_pdf {
}
#$result .= $debug;
- $result .= '<h2>'.&mt('Results of PDF Form problems').'</h2>';
- $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>$problemname</td><td class='";
- if($grade eq "EXACT_ANS" || $grade eq "APPROX_ANS") {
- $result .= "LC_answer_correct";
- } else {
- $result .= "LC_answer_charged_try";
+ $result .= '<h3>'.&mt('Result of PDF Form upload').'</h3>';
+
+ 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>';
}
- $grade = &parse_grade_answer($grade);
- $result .= "'>$grade</span></td>";
- $result .= &Apache::loncommon::end_data_table_row();
}
- $result .= &Apache::loncommon::end_data_table();
-
- return $result;
+ return $result;
}
sub grade_problem {
@@ -327,9 +377,10 @@ sub parse_grade_answer {
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) {
+ foreach my $key (keys(%answerhash)) {
if($shortcut eq $key) {
return $answerhash{$shortcut};
}
@@ -343,12 +394,12 @@ sub dumpenv {
my $r = shift;
$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 />-------------------<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 />-------------------<br />");