[MacPerl-WebCGI] file upload example?

["Axel Rose" <rose@sj.com>]

Hello all,

just wondering whether there is any working MacPerl CGI for file
uploading
available.

I tried the sample script from O'Reilly Book "CGI Programming with Perl"
but had no success. Testing was with QPQ2.1.2 as server and iCab, MSIE5,
NS47 as client.

The source code follows below.
NS reports "no data received" or diagnostics output "$fh only opened for
input",
sometimes crashes. MS IE5 reports "malformed multpart data". iCab does
nothing.

Just wondering - there is no real need for the facility.
Because of the known limitations with MacPerl and CGI at the moment I
will
use WebStar's upload plug-in in the production environment.

---
#!/usr/bin/perl -w
# -T

use strict;
use CGI 2.47;
use Fcntl qw( :DEFAULT :flock );

use constant UPLOAD_DIR     => "Festplatte:wwwroot:upload-dir:";
use constant BUFFER_SIZE    => 16_384;
use constant MAX_FILE_SIZE  => 1_048_576;       # Limit each upload to 1
MB
use constant MAX_DIR_SIZE   => 100 * 1_048_576; # Limit total uploads to
100 MB
use constant MAX_OPEN_TRIES => 100;

$CGI::DISABLE_UPLOADS   = 0;
$CGI::POST_MAX          = MAX_FILE_SIZE;

my $q = new CGI;
$q->cgi_error and error( $q, "Error transferring file: " . $q->cgi_error
);

my $file      = $q->param( "file" )     || error( $q, "No file
received." );
my $filename  = $q->param( "filename" ) || error( $q, "No filename
entered." );
my $fh        = $q->upload( $file );
my $buffer    = "";

if ( dir_size( UPLOAD_DIR ) + $ENV{CONTENT_LENGTH} > MAX_DIR_SIZE ) {
    error( $q, "Upload directory is full." );
}

# Allow letters, digits, periods, underscores, dashes
# Convert anything else to an underscore
$filename =~ s/[^\w.-]/_/g;
if ( $filename =~ /^(\w[\w.-]*)/ ) {
    $filename = $1;
}
else {
    error( $q, "Invalid file name; files must start with a letter or
number." );
}

# Open output file, making sure the name is unique
## until ( sysopen OUTPUT, UPLOAD_DIR . $filename, O_CREAT | O_EXCL ) {
until ( sysopen OUTPUT, UPLOAD_DIR . $filename, 2 ) {
    $filename =~ s/(\d*)(\.\w+)$/($1||0) + 1 . $2/e;
    $1 >= MAX_OPEN_TRIES and error( $q, "Unable to save your file." );
}

# This is necessary for non-Unix systems; does nothing on Unix
binmode $fh;
binmode OUTPUT;

# Write contents to output file
while ( read( $fh, $buffer, BUFFER_SIZE ) ) {
    print OUTPUT $buffer;
}

## Mac
unless( $^O =~ /MacOS/ ) close OUTPUT;


sub dir_size {
    my $dir = shift;
    my $dir_size = 0;
    
    # Loop through files and sum the sizes; doesn't descend down subdirs
    opendir DIR, $dir or die "Unable to open $dir: $!";
    while ( readdir DIR ) {
## problems on Mac !?!?? (Axel)
##        $dir_size += -s "$dir:$_";
    }
    return $dir_size;
}


sub error {
    my( $q, $reason ) = @_;
    
    print $q->header( "text/html" ),
          $q->start_html( "Error" ),
          $q->h1( "Error" ),
          $q->p( "Your upload was not processed because the following
error ",
                 "occured: " ),
          $q->p( $q->i( $reason ) ),
          $q->end_html;
    exit;
}
---


Cheerio
Axel

==== Want to unsubscribe from this list?
==== Send mail with body "unsubscribe" to macperl-webcgi-request@macperl.org