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