Annotation of loncom/interface/lonpdfupload.pm, revision 1.3
1.1 onken 1: # The LearningOnline Network with CAPA
2: # Publication Handler
3: #
1.3 ! bisitz 4: # $Id: lonpdfupload.pm,v 1.2 2009/04/03 15:40:17 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);">
1.3 ! bisitz 146: <input type="hidden" name="type" value="upload" />
1.1 onken 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ählen
160: </td>
161: <td bgcolor="#F8F8F8">
1.3 ! bisitz 162: <input type="file" name="file" id="filename" />
1.1 onken 163: </td>
164: </tr>
165: <tr>
166: <td bgcolor="#F8F8F8" colspan="2" align="right" style="margin-right: 30px;">
1.3 ! bisitz 167: <input type="submit" name="Uploaded" value="Absenden" />
1.1 onken 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>
![[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