Annotation of loncom/interface/lonpdfupload.pm, revision 1.18
1.1 onken 1: # The LearningOnline Network with CAPA
1.12 bisitz 2: # PDF Form Upload Handler
1.1 onken 3: #
1.18 ! raeburn 4: # $Id: lonpdfupload.pm,v 1.17 2010/03/18 16:08:48 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);
1.15 raeburn 32: use Apache::lonnet;
1.1 onken 33: use Apache::lonhtmlcommon();
34: use Apache::loncommon();
1.18 ! raeburn 35: use Apache::lonnavmaps();
1.1 onken 36: use Apache::lonlocal;
1.16 raeburn 37: use File::MMagic;
1.2 onken 38: use CAM::PDF;
1.18 ! raeburn 39: use LONCAPA qw(:DEFAULT :match);
1.1 onken 40:
41: use strict;
42:
43: sub handler() {
1.2 onken 44: my $r = shift;
1.15 raeburn 45: &Apache::loncommon::content_type($r,'text/html');
46: $r->send_http_header;
47: return OK if $r->header_only;
1.13 bisitz 48:
1.16 raeburn 49: # Needs to be in a course
50: if (!$env{'request.course.fn'}) {
51: # Not in a course
52: $env{'user.error.msg'}="/adm/pdfupload:bre:0:0:Cannot upload PDF forms unless in a course";
53: return HTTP_NOT_ACCEPTABLE;
54: }
55:
1.13 bisitz 56: # Breadcrumbs
1.15 raeburn 57: my $brcrum = [{'href' => '/adm/pdfupload',
1.13 bisitz 58: 'text' => 'Upload PDF Form'}];
1.16 raeburn 59: if ($env{'form.Uploaded'} && $env{'form.file'}) {
60: push(@{$brcrum},{'href' => '',
61: 'text' => 'PDF upload result'});
62: }
1.13 bisitz 63:
64: $r->print(&Apache::loncommon::start_page('Upload PDF Form',
65: undef,
66: {'bread_crumbs' => $brcrum,})
67: );
1.2 onken 68:
1.16 raeburn 69: if ($env{'request.course.id'}) {
70: my $permission = $env{'course.'.$env{'request.course.id'}.'.canuse_pdfforms'};
71: if ($permission eq '') {
72: my %domdefs = &Apache::lonnet::get_domain_defaults($env{'course.'.$env{'request.course.id'}.'.domain'});
73: $permission = $domdefs{'canuse_pdfforms'};
74: }
75: unless ($permission) {
76: $r->print('<p class="LC_warning">'.
77: &mt('Upload of PDF forms is not permitted for this course.').
78: '</p>'.
79: &Apache::loncommon::end_page());
80: return OK;
81: }
82: } else {
83: $r->print('<p class="LC_warning">'.
1.18 ! raeburn 84: &mt('Could not determine identity of this course.').' '.
! 85: &mt('You may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
1.16 raeburn 86: '</p>'.
87: &Apache::loncommon::end_page());
88: return OK;
89: }
90:
1.2 onken 91: # if a file was upload
92: if($env{'form.Uploaded'} && $env{'form.file'}) {
1.16 raeburn 93: my $mm = new File::MMagic;
94: my $mime_type = $mm->checktype_contents($env{'form.file'});
95: if ($mime_type eq 'application/pdf') {
96: $r->print(&processPDF);
97: } else {
98: $r->print('<p class="LC_error">'
99: .&mt("The uploaded file does not appear to be a PDF file.")
100: .'</p>');
101: }
1.2 onken 102: } else {
103: # print upload form
104: $r->print(&get_javascripts);
105: $r->print(&get_uploadform);
106: }
107:
108: #link to course-content
1.6 bisitz 109: $r->print('<hr />'
110: .'<p>'."\n"
1.5 bisitz 111: .'<a href="/adm/navmaps">'."\n"
1.14 raeburn 112: .&mt('Course Contents')."\n"
1.5 bisitz 113: .'</a>'."\n"
114: .'</p>'."\n"
115: );
1.1 onken 116:
1.2 onken 117: #&dumpenv($r); #debug -> prints the environment
1.7 onken 118: $r->print(&Apache::loncommon::end_page());
1.1 onken 119: return OK;
1.2 onken 120: }
1.1 onken 121:
122: sub get_javascripts() {
1.2 onken 123:
1.6 bisitz 124: my $message = &mt('Please choose a PDF-File.');
1.1 onken 125:
1.2 onken 126: # simple test if the upload ends with ".pdf"
127: # it's only for giving a message to the user
128: my $result .= <<END
129: <script type="text/javascript">
1.18 ! raeburn 130: // <![CDATA[
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.18 ! raeburn 140: // ]]>
1.2 onken 141: </script>
1.1 onken 142: END
143: ;
144: return $result;
145: }
146:
1.2 onken 147:
1.1 onken 148: sub get_uploadform() {
1.4 onken 149:
150: my %lt = &Apache::lonlocal::texthash(
1.6 bisitz 151: 'title' => 'Upload a PDF Form with filled Form Fields',
152: 'chFile' => 'File',
153: 'submit' => 'Upload',
1.4 onken 154: );
155:
1.5 bisitz 156: my $result =
157: '<br />'
1.18 ! raeburn 158: .'<form method="post" enctype="multipart/form-data" onsubmit="return checkFilename(this);" action="">'
1.5 bisitz 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()
1.13 bisitz 167: .'<p>'
1.5 bisitz 168: .'<input type="submit" name="Uploaded" value="'.$lt{'submit'}.'" />'
1.13 bisitz 169: .'</p>'
1.5 bisitz 170: .'</form>'
1.6 bisitz 171: .'<br />';
1.5 bisitz 172:
1.1 onken 173: return $result;
174: }
175:
176: sub processPDF {
1.2 onken 177: my $result = (); # message for Browser
178: my @pdfdata = (); # answers from PDF-Forms
1.1 onken 179:
1.2 onken 180: @pdfdata = &get_pdf_data(); # get answers from PDF-Form
1.1 onken 181:
182: if (scalar @pdfdata) {
1.2 onken 183: &grade_pdf(@pdfdata);
1.1 onken 184: } else {
1.6 bisitz 185: $result .= '<p class="LC_error">'
186: .&mt("Can't find any valid PDF formfields.")
187: .'</p>';
1.1 onken 188: }
189: }
190:
191: sub get_pdf_data() {
192: my @data = ();
1.2 onken 193: my $pdf = CAM::PDF->new($env{'form.file'});
194:
195: my @formFields = $pdf->getFormFieldList(); #get names of formfields
1.1 onken 196:
1.2 onken 197: foreach my $field (@formFields) {
198: my $dict = $pdf->getFormFieldDict($pdf->getFormField($field)); # get formfield dictonary
1.1 onken 199:
1.2 onken 200: #
1.15 raeburn 201: # this is necessary because CAM::PDF has a problem with formfieldnames which include a
1.2 onken 202: # dot in fieldnames. So a fieldname like "i.am.aFormfield" will offer three fieldnames "i", "i.am"
203: # and "i.am.aFormfield". The fragmentary names keep no values and will be ignored.
204: if($dict->{'V'}) {
205: push(@data, $field."?". $dict->{'V'}{'value'}); #binding fieldname with value
206: }
207: }
1.1 onken 208: return @data;
209: }
210:
211: sub grade_pdf {
212: my $result = ();
213: my @pdfdata = @_;
1.18 ! raeburn 214: my ($result,$meta,%grades,%problems,%foreigncourse,$debug);
! 215:
! 216: my $navmap = Apache::lonnavmaps::navmap->new();
! 217: if (!defined($navmap)) {
! 218: $result = '<h3>'.&mt('Verification of PDF form items failed').'</h3>'.
! 219: '<div class="LC_error">'.
! 220: &mt('Unable to retrieve information about course contents').' '.
! 221: &mt('You may need to [_1]re-select[_2] the course.','<a href="/adm/roles">','</a>').
! 222: '</div>';
! 223: return $result;
! 224: }
! 225: my %restitles;
! 226: foreach my $res ($navmap->retrieveResources()) {
! 227: my $symb = $res->symb;
! 228: $restitles{$symb} = $res->compTitle();
! 229: }
1.1 onken 230:
231: $debug .= "Found: ". scalar @pdfdata." Entries \n";
1.4 onken 232:
1.1 onken 233: foreach my $entry (sort(@pdfdata)) {
234: if ($entry =~ /^meta.*/) {
1.2 onken 235: $debug .= 'found: metadata -> '.$entry . "<br />";
236: my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
1.1 onken 237: my ($domain, $user) = split('&', $value);
1.4 onken 238: $user =~ s/(.*)\n/$1/; #TODO is that equals to chomp?
1.1 onken 239: if($user ne $env{'user.name'} or $domain ne $env{'user.domain'}) {
1.12 bisitz 240: return '<p class="LC_error">'
241: .&mt('Wrong username ([_1]) found in PDF file. Expected username: [_2]'
242: ,$user.':'.$domain
243: ,$env{'user.domain'}.':'.$env{'user.name'})
244: .'</p>';
1.1 onken 245: }
246:
1.17 raeburn 247: } elsif ($entry =~ /^upload.*/) {
1.1 onken 248: $debug .= 'found: a problem -> '.$entry;
1.2 onken 249: my ($label, $value) = ($entry =~ /^([^?]*)\?(.*)/);
1.1 onken 250: my ($symb, $part, $type, $HWVAL) = split('&', $label);
1.17 raeburn 251: my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
1.18 ! raeburn 252: if ($map =~ m{^uploaded/($match_domain)/($match_courseid)/default(_?\d*)\.(page|sequence)}) {
! 253: my $mapcid = $1.'_'.$2;
! 254: if ($mapcid ne $env{'request.course.id'}) {
! 255: push(@{$foreigncourse{$mapcid}},$symb);
! 256: }
! 257: }
! 258: next unless (exists($restitles{$symb}));
1.1 onken 259: $value =~ s/(.*)\n/$1/;
260:
1.6 bisitz 261: #filter incorrect radiobuttons (Bug in CABAReT Stage)
1.17 raeburn 262: if ($type eq 'radiobuttonresponse' && $value eq 'Off' ) {
1.1 onken 263: next;
264: }
265:
266: my $submit = $part;
267: $submit =~ s/part_(.*)/submit_$1/;
1.17 raeburn 268: if ($problems{$symb.$part}) {
1.1 onken 269: $problems{$symb.$part}{$HWVAL} = $value;
270: } else {
271: $problems{$symb.$part} = { 'resource' => $resource,
1.11 onken 272: 'symb' => $symb,
1.1 onken 273: 'submitted' => $part,
274: $submit => 'Answer',
275: $HWVAL => $value};
276: }
277: } else {
278: $debug .= 'found: -> '.$entry;
279: next;
280: }
281: }
1.4 onken 282: #$result .= $debug;
1.1 onken 283:
1.18 ! raeburn 284: $result .= '<h3>'.&mt('Result of PDF Form upload').'</h3>';
1.17 raeburn 285:
286: if (keys(%problems) > 0) {
287: $result .= &Apache::loncommon::start_data_table()
288: .&Apache::loncommon::start_data_table_header_row()
289: .'<th>'.&mt('Problem Name').'</th>'
290: .'<th>'.&mt('Grading').'</th>'
291: .&Apache::loncommon::start_data_table_header_row()
292: .&Apache::loncommon::end_data_table_header_row();
293:
294: foreach my $key (sort(keys(%problems))) {
295: my %problem = %{$problems{$key}};
296: my ($problemname, $grade) = &grade_problem(%problem);
297:
298: $result .= &Apache::loncommon::start_data_table_row();
1.18 ! raeburn 299: $result .= '<td><a href="/res/'.$problem{'resource'}.
! 300: '?symb='.
! 301: &HTML::Entities::encode($problem{'symb'},'"&<>').
! 302: '">'.$problemname.'</a></td><td class="';
1.17 raeburn 303: if ($grade eq "EXACT_ANS" || $grade eq "APPROX_ANS") {
1.18 ! raeburn 304: $result .= 'LC_answer_correct';
1.17 raeburn 305: } else {
1.18 ! raeburn 306: $result .= 'LC_answer_charged_try';
1.17 raeburn 307: }
1.18 ! raeburn 308: $result .= '">';
1.17 raeburn 309: $grade = &parse_grade_answer($grade);
1.18 ! raeburn 310: $result .= $grade.'</span></td>';
1.17 raeburn 311: $result .= &Apache::loncommon::end_data_table_row();
1.1 onken 312: }
1.17 raeburn 313: $result .= &Apache::loncommon::end_data_table();
314: } else {
315: $result .= '<p class="LC_warning">'.
316: &mt('As no gradable form items were found, no submissions have been recorded.').
317: '</p>';
1.4 onken 318: }
1.18 ! raeburn 319: if (keys(%foreigncourse)) {
! 320: my ($numother,$othercrsmsg);
! 321: foreach my $cid (sort(keys(%foreigncourse))) {
! 322: my %coursehash = &Apache::lonnet::coursedescription($cid,
! 323: {'one_time' => 1});
! 324: if (ref($foreigncourse{$cid}) eq 'ARRAY') {
! 325: if ($numother) {
! 326: $othercrsmsg .= '</li><li>';
! 327: }
! 328: $othercrsmsg .= '<b>'.$coursehash{'description'}.'</b><ul>'."\n";
! 329: foreach my $symb (@{$foreigncourse{$cid}}) {
! 330: my ($map,$id,$resource)=&Apache::lonnet::decode_symb($symb);
! 331: $othercrsmsg .= '<li>'.$resource.'</li>';
! 332: }
! 333: $othercrsmsg .= '</ul>';
! 334: $numother ++;
! 335: }
! 336: }
! 337: if ($numother) {
! 338: $result .= '<div class="LC_warning">';
! 339: if ($numother > 1) {
! 340: $result .= &mt('Your uploaded PDF form contained the following resource(s) from [_1] different courses:','<b>'.$numother.'</b>')."\n".'<ul><li>'.
! 341: $othercrsmsg.'</li></ul>';
! 342: } else {
! 343: $result .= &mt('Your uploaded PDF form contained the following resource(s) from a different course:').' '.$othercrsmsg.
! 344: &mt('Did you download the PDF form from another course and upload it to the wrong course?');
! 345: }
! 346: $result .= '</div>';
! 347: }
! 348: }
1.1 onken 349:
1.18 ! raeburn 350: return $result;
1.1 onken 351: }
352:
353: sub grade_problem {
354: my %problem = @_;
1.7 onken 355: my ($title, $part) = ();
1.1 onken 356:
1.7 onken 357: &Apache::loncommon::ssi_with_retries('/res/'.$problem{'resource'}, 5, %problem);
1.1 onken 358:
1.7 onken 359: $title = &Apache::lonnet::gettitle($problem{'symb'});
360: $part = $problem{submitted};
1.1 onken 361: $part =~ s/part_(.*)/$1/;
1.7 onken 362: unless($part eq '0') {
363: #add information about part number
364: $title .= " - Part $part";
365: }
1.1 onken 366:
367: my %problemhash = &Apache::lonnet::restore($problem{'symb'});
368: my $grade = $problemhash{"resource.$part.award"};
369:
1.7 onken 370: return ($title, $grade);
1.1 onken 371: }
372:
1.8 onken 373: sub parse_grade_answer {
374: my ($shortcut) = @_;
375: my %answerhash = ('EXACT_ANS' => &mt('You are correct.'),
1.10 onken 376: 'APPROX_ANS' => &mt('You are correct.'),
1.8 onken 377: 'INCORRECT' => &mt('You are incorrect'),
378: );
379:
380: foreach my $key (keys %answerhash) {
381: if($shortcut eq $key) {
382: return $answerhash{$shortcut};
383: }
384: }
385: return &mt('See course contents for further information.');
386:
387: }
388:
389:
1.1 onken 390: sub dumpenv {
391: my $r = shift;
392:
393: $r->print ("<br />-------------------<br />");
394: foreach my $key (sort (keys %env)) {
395: $r->print ("<br />$key -> $env{$key}");
396: }
397: $r->print ("<br />-------------------<br />");
398: $r->print ("<br />-------------------<br />");
399: foreach my $key (sort (keys %ENV)) {
400: $r->print ("<br />$key -> $ENV{$key}");
401: }
402: $r->print ("<br />-------------------<br />");
403:
404: }
405:
406: 1;
407: __END__
408:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonpdfupload.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface