#!/usr/bin/perl -w
use strict;
$|++;

## configuration

my $FROM = 'webmaster@www.stonehenge.comXX';
my $TO = 'merlyn+upload@stonehenge.comXX';
my $SUBJECT = 'File upload';
my $INCLUDE_META = 1;

## end configuration

use CGI qw(:all);

my @params = param();
if (my $error = cgi_error()) {
  print header(-status => $error);
  exit 0;
}

print
  header,
  start_html("Upload"),
  h1("Upload"),
  hr,
  start_multipart_form,
  table(Tr(td(p('upload:')),
           td(filefield('uploaded_file'))),
        Tr(td(p('email as type:')),
           td(radio_group('type', [qw(binary text)]))),
        Tr(td({ -colspan => 2 },
              checkbox(-name => 'strip_resource_fork',
                       -label => 'Strip Macbinary Resource Fork'))),
        Tr(td({ -colspan => 2 }, submit))),
  end_multipart_form,
  hr;

if (@params) {
  require MIME::Lite;
  if (my $file = upload('uploaded_file')) {
    my $info = uploadInfo($file) or die "info?";
    my $msg = MIME::Lite->new
      (Type => 'multipart/mixed',
       From => $FROM, To => $TO, Subject => $SUBJECT);
    if ($INCLUDE_META) {
      $msg->attach
        (Type => 'TEXT', Encoding => '7bit',
         Data => [
                  "Upload info:\n",
                  (map { "$_ => $info->{$_}\n" } sort keys %$info),
                  "ENV:\n",
                  (map { "$_ => $ENV{$_}\n" } sort keys %ENV),
                 ],
        );
    }
    $msg->attach
      ((param('type') eq 'text' ?
        (Type => 'TEXT', Encoding => 'quoted-printable') :
        (Type => 'BINARY', Encoding => 'base64')),
       ((param('strip_resource_fork') &&
         $info->{"Content-Type"} eq "application/x-macbinary") ?
        (Data => strip_fork_from_fh($file)) :
        (FH => $file)),
      );
    if ($msg->send_by_smtp('localhost')) {
      print p("Upload sent by email.");
    } else {
      print
        p("An error occurred... here's what would have been sent:"),
        pre($msg->as_string);
    }
  }
}
print end_html;

sub strip_fork_from_fh {
  my $fh = shift;

  my $len = read $fh, (my $buf), 128; # read the header
  die "short read: $len" unless $len == 128;
  my $bytes = unpack("x83N", $buf); # get datafork length
  read $fh, $buf, $bytes;
  $buf;
}