#!/usr/bin/perl -T
#
# public file upload for individual users
#
# Edwin Thaler, February 2000
# HTML-layout taken from Tobis Vacation Editor

BEGIN {
    umask 022;
    if ( exists $ENV{SCRIPT_FILENAME} ) {
        select(STDOUT);
        $| = 1;    # make unbuffered
        select(STDERR);
        $| = 1;    # make unbuffered
        open( STDERR, ">&STDOUT" ) || die "Can't dup stdout";
    }
    $SIG{__WARN__} = sub { die "\n\n\nWarning: $_[0]\n"; };
    $SIG{__DIE__}  = sub { die "\n\n\n$_[0]\n" };
}

use CGI qw(:standard);
use warnings;
use strict;

my $WIDTH = 600;
my $FONT  = 'FACE="Arial,Helvetica,Swiss"';
$ENV{PATH} = "/usr/bin:/usr/sepp/bin";
my $maxbytes = 20000000;    # upload files size limit
$CGI::POST_MAX = $maxbytes;
my $q      = new CGI;
my $user   = 'thaler';
my %colors = (
    'title_bar_fg' => "#ffffff",
    'title_bar_bg' => "#104e8b",
    'title_url'    => "#ff0000",
    'input_bg'     => "#dadada",
    'input_fg'     => "#000080",
    'input_frame'  => "#104e8b",
    'info_bg'      => "#c6e2ff",
    'info_fg'      => "#000000",
    'info_frame'   => "#104e8b",
    'error_bg'     => "#ff82ab",
    'error_fg'     => "#000000",
    'error_frame'  => "#104e8b"
);

sub SS_Header ();
sub SS_Error ($$);
sub SS_Warning ($);
sub SS_Footer ();
sub SS_Frame ($$@);
sub SS_Upload_Input ();
sub SS_Upload_File ();

my ( $login, $full, $home ) = ( getpwuid($<) )[ 0, 6, 7 ]
    or die "You don't exist, go away\n";
my $name = ( split /,/, $full )[0];

# MAIN PROGRAM
my $act = scalar $q->param('action') // 'Welcome';
my $error = $q->cgi_error;
$ENV{SCRIPT_NAME} =~ m|^/~(.+)/upload/.*|;
$user = $1 if defined $1;
SS_Header;
SS_Error( "User Idenfication", "no valid user" ) unless -d "$home";
SS_Error( "MAIN (unexpected)", $error ) if defined $error;
ASWITCH: for ($act) {
    /^Upload File$/ && do { SS_Upload_File; SS_Upload_Input; last };
    /^Cancel$/
        && do { SS_Warning("No file uploaded"); SS_Upload_Input; last };
    /^Welcome$/ && do { SS_Upload_Input; last };
}
SS_Footer;

# END MAIN

sub SS_Upload_Input () {
    SS_Frame(
        "input", $WIDTH,
        $q->start_multipart_form(),
        "<P><B><SMALL>Select file to upload:</SMALL></B><BR>",
        $q->filefield(
            -name      => 'filename',
            -default   => '',
            -size      => 50,
            -maxlength => 80
        ),
        "<P>",
        $q->submit(
            -name  => 'action',
            -value => 'Upload File'
        ),
        "or",
        $q->submit(
            -name  => 'action',
            -value => 'Cancel'
        ),
        $q->end_form()
    );
}

sub SS_Upload_File () {
    my $file;
    my $filename;
    my $savefile = "$home/public_upload/";
    my ( $buffer, $bytesread );
    my $bytestotal = 0;

    if ( $file = $q->param('filename') ) {

        # remove full path
        $filename = $file;
        $filename =~ /([^\/\\:]+)$/;
        $savefile .= $1;
        SS_Error( "Upload_File", "$savefile allready exists!" )
            if -f $savefile;
        open( OUTFILE, ">$savefile" )
            or SS_Error( "Upload_File", "cannot open  $savefile" );
        while ( ( $bytesread = read( $file, $buffer, 1024 ) )
            and ( $bytestotal < $maxbytes ) )
        {
            $bytestotal += $bytesread;
            print OUTFILE $buffer
                or SS_Error( "Upload_File", "cannot write to  $savefile" );
        }
        close(OUTFILE)
            or SS_Error( "Upload_File", "cannot close  $savefile" );
        if ( $bytestotal == 0 ) {
            unlink $savefile;
            SS_Error( "Upload_File",
                "upload failed for unknown reason (file size to large?)" );
        }
        elsif ( $bytestotal > $maxbytes ) {
            unlink $savefile;
            SS_Error( "Upload_File",
                "upload file size limit of $maxbytes bytes exceeded" );
        }
        else {
            SS_Warning(
                "File successfully uploaded: $filename ($bytestotal bytes)");
        }
    }
    else {
        SS_Warning("No filename found");
    }
}

sub SS_Header () {

    # we put a white table around everything in order to get
    # the right color with form elements ... a netscape quirck ...
    print $q->header;
    print $q->start_html(
        '-title' => "Upload file for user $name",
        -author  => 'Edwin Thaler <thaler@ee.ethz.ch>',
        -BGCOLOR => '#ffffff'
    );
    print <<TEXT;
<TABLE WIDTH=$WIDTH BORDER=0 CELLPADDING=4 CELLSPACING=0 BGCOLOR=black><TR>
  <TD BGCOLOR=$colors{'title_bar_bg'}>
  <FONT COLOR=$colors{'title_bar_fg'} SIZE=+2>
Upload file for <A HREF=/~$user> <FONT COLOR=$colors{'title_url'}> $name </FONT></A>
</FONT></TD>
</TR></TABLE>
<P>
TEXT
}

sub SS_Error ($$) {
    my ( $loc, $text ) = @_;
    $text =~ s/\n/<BR>\n/g;
    print "<P>";
    &SS_Frame( 'error', $WIDTH, "<H3>Error in '<B>$loc</B>'</H3>\n$text" );
    &SS_Footer;
    print "</BODY></HTML>";
    exit 1;
}

sub SS_Warning ($) {
    my ($text) = @_;
    $text =~ s/\n/<BR>\n/g;
    print "<P>";
    &SS_Frame( 'info', $WIDTH, $text );
    print "<P>";
}

sub SS_Footer () {
    print <<TEXT;
<TABLE CELLPADDING=0 CELLSPACING=0 WIDTH=$WIDTH BORDER=0><TR>
<TD ALIGN=RIGHT><SMALL><B>File Upload Script</B> by Edwin Thaler
&lt;<A HREF="mailto:thaler\@ee.ethz.ch">thaler\@ee.ethz.ch</A>&gt;</SMALL></TD></TR>
</TABLE>
TEXT

    # print map ({"$_ = $ENV{$_}<BR>"} keys %ENV);
}

sub SS_Frame ($$@) {
    my ( $color, $width, @text ) = @_;
    print "<TABLE WIDTH=$width BORDER=0 CELLPADDING=1 "
        . "CELLSPACING=0 BGCOLOR=\""
        . $colors{ ${color} . "_frame" }
        . "\"><TR><TD>\n";
    print "<TABLE WIDTH=100% BORDER=0 CELLSPACING=0 " . "CELLPADDING=8><TR>";
    print "<TD BGCOLOR=\"" . $colors{ ${color} . "_bg" } . "\">\n";
    print "<FONT COLOR=\"" . $colors{ ${color} . "_fg" } . "\">\n";
    print join "\n", @text;
    print "</FONT></TD></TR></TABLE></TD></TR></TABLE>\n";
}

__END__

=pod

=head1 NAME

index.cgi - File Upload CGI-Script

=head1 SYNOPSYS

B<index.cgi> must be run from the web

=head1 DESCRIPTION

An http upload interface for the personal homepage

=head1 USAGE

You must install this CGI as

B<~/public_html/upload/index.cgi>

and create a directory B<~/public_upload/> writeable only for your account.
The script is run with the rights of your account (through apache's suexec
mechanism).

You can restrict the access to the upload.cgi-script with 
a B<.htaccess> file in ~/public_html/upload/. You kan find infos
under http://computing.ee.ethz.ch/.soft/htaccess

The files are uploaded to ~/public_upload/.

=head1 COPYRIGHT

Copyright (c) 2001 by ETH Zurich. All rights reserved.

=head1 LICENSE


This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

=head1 AUTHOR

Edwin Thaler E<lt>thaler@ee.ethz.chE<gt>

=head1 HISTORY

 2002-01-01 et Initial Version
 2004-06-11 mo update for perl 5.8.4
 2008-02-11 et enhanced errorhandlingn update to 5.8.8
 2017-06-30 bs Ported for CGI 3.65

=cut