1 #!/usr/bin/perl -T
   2 #
   3 # public file upload for individual users
   4 #
   5 # Edwin Thaler, February 2000
   6 # HTML-layout taken from Tobis Vacation Editor
   7 
   8 BEGIN {
   9     umask 022;
  10     if ( exists $ENV{SCRIPT_FILENAME} ) {
  11         select(STDOUT);
  12         $| = 1;    # make unbuffered
  13         select(STDERR);
  14         $| = 1;    # make unbuffered
  15         open( STDERR, ">&STDOUT" ) || die "Can't dup stdout";
  16     }
  17     $SIG{__WARN__} = sub { die "\n\n\nWarning: $_[0]\n"; };
  18     $SIG{__DIE__}  = sub { die "\n\n\n$_[0]\n" };
  19 }
  20 
  21 use CGI qw(:standard);
  22 use warnings;
  23 use strict;
  24 
  25 my $WIDTH = 600;
  26 my $FONT  = 'FACE="Arial,Helvetica,Swiss"';
  27 $ENV{PATH} = "/usr/bin:/usr/sepp/bin";
  28 my $maxbytes = 20000000;    # upload files size limit
  29 $CGI::POST_MAX = $maxbytes;
  30 my $q      = new CGI;
  31 my $user   = 'thaler';
  32 my %colors = (
  33     'title_bar_fg' => "#ffffff",
  34     'title_bar_bg' => "#104e8b",
  35     'title_url'    => "#ff0000",
  36     'input_bg'     => "#dadada",
  37     'input_fg'     => "#000080",
  38     'input_frame'  => "#104e8b",
  39     'info_bg'      => "#c6e2ff",
  40     'info_fg'      => "#000000",
  41     'info_frame'   => "#104e8b",
  42     'error_bg'     => "#ff82ab",
  43     'error_fg'     => "#000000",
  44     'error_frame'  => "#104e8b"
  45 );
  46 
  47 sub SS_Header ();
  48 sub SS_Error ($$);
  49 sub SS_Warning ($);
  50 sub SS_Footer ();
  51 sub SS_Frame ($$@);
  52 sub SS_Upload_Input ();
  53 sub SS_Upload_File ();
  54 
  55 my ( $login, $full, $home ) = ( getpwuid($<) )[ 0, 6, 7 ]
  56     or die "You don't exist, go away\n";
  57 my $name = ( split /,/, $full )[0];
  58 
  59 # MAIN PROGRAM
  60 my $act = scalar $q->param('action') // 'Welcome';
  61 my $error = $q->cgi_error;
  62 $ENV{SCRIPT_NAME} =~ m|^/~(.+)/upload/.*|;
  63 $user = $1 if defined $1;
  64 SS_Header;
  65 SS_Error( "User Idenfication", "no valid user" ) unless -d "$home";
  66 SS_Error( "MAIN (unexpected)", $error ) if defined $error;
  67 ASWITCH: for ($act) {
  68     /^Upload File$/ && do { SS_Upload_File; SS_Upload_Input; last };
  69     /^Cancel$/
  70         && do { SS_Warning("No file uploaded"); SS_Upload_Input; last };
  71     /^Welcome$/ && do { SS_Upload_Input; last };
  72 }
  73 SS_Footer;
  74 
  75 # END MAIN
  76 
  77 sub SS_Upload_Input () {
  78     SS_Frame(
  79         "input", $WIDTH,
  80         $q->start_multipart_form(),
  81         "<P><B><SMALL>Select file to upload:</SMALL></B><BR>",
  82         $q->filefield(
  83             -name      => 'filename',
  84             -default   => '',
  85             -size      => 50,
  86             -maxlength => 80
  87         ),
  88         "<P>",
  89         $q->submit(
  90             -name  => 'action',
  91             -value => 'Upload File'
  92         ),
  93         "or",
  94         $q->submit(
  95             -name  => 'action',
  96             -value => 'Cancel'
  97         ),
  98         $q->end_form()
  99     );
 100 }
 101 
 102 sub SS_Upload_File () {
 103     my $file;
 104     my $filename;
 105     my $savefile = "$home/public_upload/";
 106     my ( $buffer, $bytesread );
 107     my $bytestotal = 0;
 108 
 109     if ( $file = $q->param('filename') ) {
 110 
 111         # remove full path
 112         $filename = $file;
 113         $filename =~ /([^\/\\:]+)$/;
 114         $savefile .= $1;
 115         SS_Error( "Upload_File", "$savefile allready exists!" )
 116             if -f $savefile;
 117         open( OUTFILE, ">$savefile" )
 118             or SS_Error( "Upload_File", "cannot open  $savefile" );
 119         while ( ( $bytesread = read( $file, $buffer, 1024 ) )
 120             and ( $bytestotal < $maxbytes ) )
 121         {
 122             $bytestotal += $bytesread;
 123             print OUTFILE $buffer
 124                 or SS_Error( "Upload_File", "cannot write to  $savefile" );
 125         }
 126         close(OUTFILE)
 127             or SS_Error( "Upload_File", "cannot close  $savefile" );
 128         if ( $bytestotal == 0 ) {
 129             unlink $savefile;
 130             SS_Error( "Upload_File",
 131                 "upload failed for unknown reason (file size to large?)" );
 132         }
 133         elsif ( $bytestotal > $maxbytes ) {
 134             unlink $savefile;
 135             SS_Error( "Upload_File",
 136                 "upload file size limit of $maxbytes bytes exceeded" );
 137         }
 138         else {
 139             SS_Warning(
 140                 "File successfully uploaded: $filename ($bytestotal bytes)");
 141         }
 142     }
 143     else {
 144         SS_Warning("No filename found");
 145     }
 146 }
 147 
 148 sub SS_Header () {
 149 
 150     # we put a white table around everything in order to get
 151     # the right color with form elements ... a netscape quirck ...
 152     print $q->header;
 153     print $q->start_html(
 154         '-title' => "Upload file for user $name",
 155         -author  => 'Edwin Thaler <thaler@ee.ethz.ch>',
 156         -BGCOLOR => '#ffffff'
 157     );
 158     print <<TEXT;
 159 <TABLE WIDTH=$WIDTH BORDER=0 CELLPADDING=4 CELLSPACING=0 BGCOLOR=black><TR>
 160   <TD BGCOLOR=$colors{'title_bar_bg'}>
 161   <FONT COLOR=$colors{'title_bar_fg'} SIZE=+2>
 162 Upload file for <A HREF=/~$user> <FONT COLOR=$colors{'title_url'}> $name </FONT></A>
 163 </FONT></TD>
 164 </TR></TABLE>
 165 <P>
 166 TEXT
 167 }
 168 
 169 sub SS_Error ($$) {
 170     my ( $loc, $text ) = @_;
 171     $text =~ s/\n/<BR>\n/g;
 172     print "<P>";
 173     &SS_Frame( 'error', $WIDTH, "<H3>Error in '<B>$loc</B>'</H3>\n$text" );
 174     &SS_Footer;
 175     print "</BODY></HTML>";
 176     exit 1;
 177 }
 178 
 179 sub SS_Warning ($) {
 180     my ($text) = @_;
 181     $text =~ s/\n/<BR>\n/g;
 182     print "<P>";
 183     &SS_Frame( 'info', $WIDTH, $text );
 184     print "<P>";
 185 }
 186 
 187 sub SS_Footer () {
 188     print <<TEXT;
 189 <TABLE CELLPADDING=0 CELLSPACING=0 WIDTH=$WIDTH BORDER=0><TR>
 190 <TD ALIGN=RIGHT><SMALL><B>File Upload Script</B> by Edwin Thaler
 191 &lt;<A HREF="mailto:thaler\@ee.ethz.ch">thaler\@ee.ethz.ch</A>&gt;</SMALL></TD></TR>
 192 </TABLE>
 193 TEXT
 194 
 195     # print map ({"$_ = $ENV{$_}<BR>"} keys %ENV);
 196 }
 197 
 198 sub SS_Frame ($$@) {
 199     my ( $color, $width, @text ) = @_;
 200     print "<TABLE WIDTH=$width BORDER=0 CELLPADDING=1 "
 201         . "CELLSPACING=0 BGCOLOR=\""
 202         . $colors{ ${color} . "_frame" }
 203         . "\"><TR><TD>\n";
 204     print "<TABLE WIDTH=100% BORDER=0 CELLSPACING=0 " . "CELLPADDING=8><TR>";
 205     print "<TD BGCOLOR=\"" . $colors{ ${color} . "_bg" } . "\">\n";
 206     print "<FONT COLOR=\"" . $colors{ ${color} . "_fg" } . "\">\n";
 207     print join "\n", @text;
 208     print "</FONT></TD></TR></TABLE></TD></TR></TABLE>\n";
 209 }
 210 
 211 __END__
 212 
 213 =pod
 214 
 215 =head1 NAME
 216 
 217 index.cgi - File Upload CGI-Script
 218 
 219 =head1 SYNOPSYS
 220 
 221 B<index.cgi> must be run from the web
 222 
 223 =head1 DESCRIPTION
 224 
 225 An http upload interface for the personal homepage
 226 
 227 =head1 USAGE
 228 
 229 You must install this CGI as
 230 
 231 B<~/public_html/upload/index.cgi>
 232 
 233 and create a directory B<~/public_upload/> writeable only for your account.
 234 The script is run with the rights of your account (through apache's suexec
 235 mechanism).
 236 
 237 You can restrict the access to the upload.cgi-script with 
 238 a B<.htaccess> file in ~/public_html/upload/. You kan find infos
 239 under http://computing.ee.ethz.ch/.soft/htaccess
 240 
 241 The files are uploaded to ~/public_upload/.
 242 
 243 =head1 COPYRIGHT
 244 
 245 Copyright (c) 2001 by ETH Zurich. All rights reserved.
 246 
 247 =head1 LICENSE
 248 
 249 
 250 This program is free software; you can redistribute it and/or modify
 251 it under the terms of the GNU General Public License as published by
 252 the Free Software Foundation; either version 2 of the License, or
 253 (at your option) any later version.
 254 
 255 This program is distributed in the hope that it will be useful,
 256 but WITHOUT ANY WARRANTY; without even the implied warranty of
 257 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 258 GNU General Public License for more details.
 259 
 260 You should have received a copy of the GNU General Public License
 261 along with this program; if not, write to the Free Software
 262 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 263 
 264 =head1 AUTHOR
 265 
 266 Edwin Thaler E<lt>thaler@ee.ethz.chE<gt>
 267 
 268 =head1 HISTORY
 269 
 270  2002-01-01 et Initial Version
 271  2004-06-11 mo update for perl 5.8.4
 272  2008-02-11 et enhanced errorhandlingn update to 5.8.8
 273  2017-06-30 bs Ported for CGI 3.65
 274 
 275 =cut