Annotation of loncom/publisher/lonupload.pm, revision 1.24
1.12 foxr 1:
1.1 www 2: # The LearningOnline Network with CAPA
3: # Handler to upload files into construction space
4: #
1.24 ! albertel 5: # $Id: lonupload.pm,v 1.23 2003/11/08 11:11:01 albertel Exp $
1.8 matthew 6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
13: # the Free Software Foundation; either version 2 of the License, or
14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
27: # http://www.lon-capa.org/
28: #
1.10 harris41 29: ###
1.1 www 30:
31: package Apache::lonupload;
32:
33: use strict;
34: use Apache::File;
35: use File::Copy;
1.13 foxr 36: use File::Basename;
1.1 www 37: use Apache::Constants qw(:common :http :methods);
1.3 www 38: use Apache::loncacc;
1.10 harris41 39: use Apache::loncommon();
1.12 foxr 40: use Apache::Log();
1.13 foxr 41: use Apache::lonnet;
1.14 foxr 42: use HTML::Entities();
1.20 www 43: use Apache::lonlocal;
1.12 foxr 44:
45: my $DEBUG=0;
46:
47: sub Debug {
48:
1.22 albertel 49: # Marshall the parameters.
1.12 foxr 50:
1.22 albertel 51: my $r = shift;
52: my $log = $r->log;
53: my $message = shift;
1.12 foxr 54:
1.22 albertel 55: # Put out the indicated message butonly if DEBUG is false.
1.12 foxr 56:
1.22 albertel 57: if ($DEBUG) {
58: $log->debug($message);
59: }
1.12 foxr 60: }
1.1 www 61:
1.2 www 62: sub upfile_store {
63: my $r=shift;
64:
65: my $fname=$ENV{'form.upfile.filename'};
66: $fname=~s/\W//g;
67:
1.18 www 68: chomp($ENV{'form.upfile'});
1.1 www 69:
1.2 www 70: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
71: '_upload_'.$fname.'_'.time.'_'.$$;
72: {
73: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
74: '/tmp/'.$datatoken.'.tmp');
75: print $fh $ENV{'form.upfile'};
1.1 www 76: }
1.2 www 77: return $datatoken;
78: }
79:
80:
81: sub phaseone {
1.22 albertel 82: my ($r,$fn,$uname,$udom)=@_;
83: $ENV{'form.upfile.filename'}=~s/\\/\//g;
84: $ENV{'form.upfile.filename'}=~s/^.*\/([^\/]+)$/$1/;
85: if ($ENV{'form.upfile.filename'}) {
86: $fn=~s/\/[^\/]+$//;
87: $fn=~s/([^\/])$/$1\//;
88: $fn.=$ENV{'form.upfile.filename'};
89: $fn=~s/^\///;
90: $fn=~s/(\/)+/\//g;
1.13 foxr 91:
92: # Fn is the full path to the destination filename.
93: #
94:
1.22 albertel 95: &Debug($r, "Filename for upload: $fn");
96: if (($fn) && ($fn!~/\/$/)) {
1.23 albertel 97: $r->print('<form action="/adm/upload" method="post">'.
98: '<input type="hidden" name="phase" value="two" />'.
99: '<input type="hidden" name="datatoken" value="'.
100: &upfile_store.'" />'.
101: '<input type="hidden" name="uploaduname" value="'.$uname.
102: '" />'.&mt('Store uploaded file as ').
103: "<tt>/priv/$uname/</tt>".
104: '<input type="text" size="50" name="filename" value="'.$fn.
105: '" /><br />'.
106: '<input type="submit" value="'.&mt('Store').'" /></form>');
1.22 albertel 107: # Check for bad extension and warn user
108: if ($fn=~/\.(\w+)$/ &&
109: (&Apache::loncommon::fileembstyle($1) eq 'hdn')) {
1.23 albertel 110: $r->print('<font color="red">'.&mt('The extension on this file,').
1.22 albertel 111: ' "'.$1.'"'.&mt(', is reserved internally by LON-CAPA.').
1.23 albertel 112: ' <br />'.&mt('Please change the extension.').'</font>');
1.22 albertel 113: } elsif($fn=~/\.(\w+)$/ &&
114: !defined(&Apache::loncommon::fileembstyle($1))) {
1.23 albertel 115: $r->print('<font color="red">'.&mt('The extension on this file,').
1.22 albertel 116: ' "'.$1.'"'.&mt(', is not recognized by LON-CAPA.').
1.23 albertel 117: ' <br />'.&mt('Please change the extension.').
1.22 albertel 118: '</font>');
119: }
120: } else {
1.23 albertel 121: $r->print('<font color="red">'.&mt('Illegal filename.').'</font>');
1.22 albertel 122: }
123: } else {
1.23 albertel 124: $r->print('<font color="red">'.&mt('No upload file specified.').'</font>');
1.22 albertel 125: }
1.1 www 126: }
127:
128: sub phasetwo {
1.22 albertel 129: my ($r,$tfn,$uname,$udom)=@_;
130: my $fn='/priv/'.$uname.'/'.$tfn;
131: $fn=~s/\/+/\//g;
132: &Debug($r, "Filename is ".$tfn);
133: if ($tfn) {
134: &Debug($r, "Filename for tfn = ".$tfn);
135: my $target='/home/'.$uname.'/public_html'.$tfn;
136: &Debug($r, "target -> ".$target);
1.13 foxr 137: # target is the full filesystem path of the destination file.
1.22 albertel 138: my $base = &File::Basename::basename($fn);
139: my $path = &File::Basename::dirname($fn);
140: $base = &HTML::Entities::encode($base);
141: my $url = $path."/".$base;
142: &Debug($r, "URL is now ".$url);
143: my $datatoken=$ENV{'form.datatoken'};
144: if (($fn) && ($datatoken)) {
145: if ((-e $target) && ($ENV{'form.override'} ne 'Yes')) {
1.23 albertel 146: $r->print('<form action="/adm/upload" method="post">'.
1.22 albertel 147: &mt('File').' <tt>'.$fn.'</tt> '.
148: &mt('exists. Overwrite?').' '.
1.23 albertel 149: '<input type="hidden" name="phase" value="two" />'.
150: '<input type="hidden" name="filename" value="'."$url".'" />'.
151: '<input type="hidden" name="datatoken" value="'.$datatoken.'" />'.
152: '<input type="submit" name="override" value="'.&mt('Yes').'" /></form>');
1.22 albertel 153: } else {
154: my $source=$r->dir_config('lonDaemons').'/tmp/'.$datatoken.'.tmp';
155: # Check for bad extension and disallow upload
156: if ($fn=~/\.(\w+)$/ &&
157: (&Apache::loncommon::fileembstyle($1) eq 'hdn')) {
158: $r->print(&mt('File').' <tt>'.$fn.'</tt> '.
159: &mt('could not be copied.').'<br />'.
1.23 albertel 160: '<font color="red">'.
1.22 albertel 161: &mt('The extension on this file is reserved internally by LON-CAPA.').
162: '</font>');
1.24 ! albertel 163: $r->print('<br /><font size=+2><a href="'.$path.'">'.
1.22 albertel 164: &mt('Back to Directory').'</a></font>');
165: } elsif ($fn=~/\.(\w+)$/ &&
166: !defined(&Apache::loncommon::fileembstyle($1))) {
167: $r->print(&mt('File').' <tt>'.$fn.'</tt> '.
168: &mt('could not be copied.').'<br />'.
1.23 albertel 169: '<font color="red">'.
1.22 albertel 170: &mt('The extension on this file is not recognized by LON-CAPA.').
171: '</font>');
1.23 albertel 172: $r->print('<br /><font size="+2"><a href="'.$path.'">'.
1.22 albertel 173: &mt('Back to Directory').'</a></font>');
174: } elsif (-d $target) {
175: $r->print('File <tt>'.$fn.'</tt> could not be copied.<br />'.
1.23 albertel 176: '<font color="red">'.
1.22 albertel 177: &mt('The target is an existing directory.').
1.23 albertel 178: '</font><br />');
179: $r->print('<font size="+2"><a href="'.$path.'">'.
1.22 albertel 180: &mt('Back to Directory').'</a></font>');
181: } elsif (copy($source,$target)) {
182: chmod(0660, $target); # Set permissions to rw-rw---.
183: $r->print(&mt('File copied.'));
1.23 albertel 184: $r->print('<br /><font size="+2"><a href="'.$url.'">'.
1.22 albertel 185: &mt('View file').'</a></font>');
1.24 ! albertel 186: $r->print('<br /><font size="+2"><a href="'.$path.'">'.
1.23 albertel 187: &mt('Back to Directory').'</a></font><br />');
1.22 albertel 188: } else {
189: $r->print('Failed to copy: '.$!);
1.23 albertel 190: $r->print('<br /><font size="+2"><a href="'.$path.'">'.
1.22 albertel 191: &mt('Back to Directory').'</a></font>');
192: }
193: }
194: } else {
1.23 albertel 195: $r->print('<font size="+1" color="red">'.
1.22 albertel 196: &mt('Please use browser "Back" button and pick a filename').
1.24 ! albertel 197: '</font><br />');
1.22 albertel 198: }
1.1 www 199: } else {
1.22 albertel 200: $r->print('<font size=+1 color=red>'.
201: &mt('Please use browser "Back" button and pick a filename').
1.24 ! albertel 202: '</font><br />>');
1.1 www 203: }
204: }
205:
1.10 harris41 206: # ---------------------------------------------------------------- Main Handler
1.1 www 207: sub handler {
208:
1.22 albertel 209: my $r=shift;
1.1 www 210:
1.22 albertel 211: my $uname;
212: my $udom;
1.18 www 213: #
214: # phase two: re-attach user
215: #
1.22 albertel 216: if ($ENV{'form.uploaduname'}) {
217: $ENV{'form.filename'}='/priv/'.$ENV{'form.uploaduname'}.'/'.
218: $ENV{'form.filename'};
219: }
220: #
221:
222: ($uname,$udom)=
223: &Apache::loncacc::constructaccess($ENV{'form.filename'},
224: $r->dir_config('lonDefDomain'));
225: unless (($uname) && ($udom)) {
226: $r->log_reason($uname.' at '.$udom.
227: ' trying to publish file '.$ENV{'form.filename'}.
228: ' - not authorized',
229: $r->filename);
230: return HTTP_NOT_ACCEPTABLE;
231: }
232:
233: my $fn;
234: if ($ENV{'form.filename'}) {
235: $fn=$ENV{'form.filename'};
236: $fn=~s/^http\:\/\/[^\/]+\///;
237: $fn=~s/^\///;
238: $fn=~s/(\~|priv\/)(\w+)//;
239: $fn=~s/\/+/\//g;
240: } else {
241: $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
242: ' unspecified filename for upload', $r->filename);
243: return HTTP_NOT_FOUND;
244: }
1.1 www 245:
246: # ----------------------------------------------------------- Start page output
247:
248:
1.22 albertel 249: &Apache::loncommon::content_type($r,'text/html');
250: $r->send_http_header;
1.1 www 251:
1.22 albertel 252: $r->print('<html><head><title>LON-CAPA Construction Space</title></head>');
1.1 www 253:
1.22 albertel 254: $r->print(&Apache::loncommon::bodytag('Upload file to Construction Space'));
1.3 www 255:
1.22 albertel 256: if (($uname ne $ENV{'user.name'}) || ($udom ne $ENV{'user.domain'})) {
257: $r->print('<h3><font color=red>'.&mt('Co-Author').': '.$uname.
258: &mt(' at ').$udom.'</font></h3>');
259: }
260:
261: if ($ENV{'form.phase'} eq 'two') {
262: &phasetwo($r,$fn,$uname,$udom);
263: } else {
264: &phaseone($r,$fn,$uname,$udom);
265: }
1.1 www 266:
1.22 albertel 267: $r->print('</body></html>');
268: return OK;
1.1 www 269: }
1.7 www 270:
271: 1;
272: __END__
1.10 harris41 273:
274: =head1 NAME
275:
276: Apache::lonupload - upload files into construction space
277:
278: =head1 SYNOPSIS
279:
280: Invoked by /etc/httpd/conf/srm.conf:
281:
282: <Location /adm/upload>
283: PerlAccessHandler Apache::lonacc
284: SetHandler perl-script
285: PerlHandler Apache::lonupload
286: ErrorDocument 403 /adm/login
287: ErrorDocument 404 /adm/notfound.html
288: ErrorDocument 406 /adm/unauthorized.html
289: ErrorDocument 500 /adm/errorhandler
290: </Location>
291:
292: =head1 INTRODUCTION
293:
294: This module uploads a file sitting on a client computer into
295: library server construction space.
296:
297: This is part of the LearningOnline Network with CAPA project
298: described at http://www.lon-capa.org.
299:
300: =head1 HANDLER SUBROUTINE
301:
302: This routine is called by Apache and mod_perl.
303:
304: =over 4
305:
306: =item *
307:
308: Initialize variables
309:
310: =item *
311:
312: Start page output
313:
314: =item *
315:
316: output relevant interface phase (phaseone or phasetwo)
317:
318: =item *
319:
320: (phase one is to specify upload file; phase two is to handle conditions
321: subsequent to specification--like overwriting an existing file)
322:
323: =back
324:
325: =head1 OTHER SUBROUTINES
326:
327: =over 4
328:
329: =item *
330:
331: phaseone() : Interface for specifying file to upload.
332:
333: =item *
334:
335: phasetwo() : Interface for handling post-conditions about uploading (such
336: as overwriting an existing file).
337:
338: =item *
339:
340: upfile_store() : Store contents of uploaded file into temporary space. Invoked
341: by phaseone subroutine.
342:
343: =back
344:
345: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonupload.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / publisher