#!/usr/bin/perl -wT

# F*EX CGI for upload
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Contribs:
#	Sebastian Zaiser <szcode@arcor.de> (upload status)
#

BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }

# use utf8;
use Encode;
use IO::Handle;
use File::Basename;
use Cwd		qw(abs_path getcwd);
use Fcntl 	qw(:flock :seek :mode);
use Digest::MD5	qw(md5_hex);

# add fex lib
(our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;

$| = 1;

our $debug;
our $ndata = 0;
our $error = 'F*EX upload ERROR';
our $head = "$ENV{SERVER_NAME} F*EX upload";
our $autodelete = 'YES';
our $locale;

# import from fex.ph
our ($bcc,$keep,$keep_max,$nomail,$nostore,$overwrite,$max_fail);
our ($archive_sharing,$document_exchange,$encryption);
our (@locales,@throttle);
our (@local_domains,@local_rdomains,@local_hosts,@local_rhosts);
our (@registration_hosts,@demo,@file_link_dirs);

# import from fex.pp
our ($FEXHOME);
our ($spooldir,$durl,$tmpdir,@logdir,$logdir,$docdir,$hostname,$admin,$fra);
our ($keep_default,$fex_yourself);
our ($sendmail,$mdomain,$fop_auth,$mail_auth,$faillog,$amdl,$vp);
our ($dkeydir,$ukeydir,$akeydir,$skeydir,$gkeydir,$xkeydir);
our ($MB,$DS);
our $RB = 0;		# read POST bytes (total)
our $akey = '';
our $dkey = '';
our $skey = '';
our $ukey = '';
our $gkey = '';

local $filesize = 0;	# total file size

my $seek = 0;		# already sent bytes (from previous upload)
my $fpsize = 0;		# file part size (MIME-part)
my $boundary;
my $rid = '';		# real ID
my @header;		# HTTP entity header
my $fileid;		# file ID
my $captive;
my $muser;		# main user fur sub or group user
my %specific;		# upload specific KEEP and AUTODELETE parameters
my @to = ();
my $data = '';
my $file = '';
my $comment = '';
my $command = '';
my $bwlimit = '';
my $filename = '';
my $fkey = '';
my $okey = '';
my $pkey = '';
my $share = '';
my $shared = '';
my $archive = '';
my $avt = '';
my $azip = '';
my $addto = '';
my $replyto = '';
my $submit = '';
my $owner;
my $prefetch;
my $mup = 0;
my $back = "javascript:history.back()";
my $formpara =
  'method="post" accept-charset="UTF-8" enctype="multipart/form-data"';
my $js_scroll =
  "<script>".
  "function scroll() { window.scrollTo(0,document.body.scrollHeight) }".
  "</script>\n";
my $scroll = '<script>scroll()</script>';

our $from = '';
our $to = '';
our $id = '';

# load common code, local config: $FEXLIB/fex.ph
require "$FEXLIB/fex.pp";

# load fup local config
our ($info_1,$info_2,$info_login);

$locale = $ENV{LOCALE} || 'english';
foreach (
  "/var/lib/fex/locale/$locale/lib/fup.pl",
  "$FEXLIB/fup.pl",
) {
  if (-f) {
    require;
    last;
  }
}

&check_camel unless $sid;

my $log = 'fup.log';

my $http_client = $ENV{HTTP_USER_AGENT} || '';
my $cl = $ENV{X_CONTENT_LENGTH} || $ENV{CONTENT_LENGTH} || 0;

$fra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
$locale = untaint($ENV{LOCALE}||'');

my $RA = $ENV{REMOTE_ADDR}||0;
if (@upload_hosts and not ipin($RA,@upload_hosts)) {
  http_die(
    "Uploads from your host ($RA) are not allowed.",
    "Contact $ENV{SERVER_ADMIN} for details."
  );
}
if ($max_fail and $faillog and not $ENV{HTTP_X_FORWARDED_FOR} and
    open $faillog,$faillog) {
  my $n = 0;
  $n++ while <$faillog>;
  close $faillog;
  if ($n > $max_fail) {
    http_die(
      "Too many login failures from $RA : IP BLOCKED",
      "Contact $ENV{SERVER_ADMIN} for details."
    );
  }
}

&check_maint;

&parse_request; # showstatus will not come back!

if ($addto) {
  my %to;
  foreach $to (@to) { $to{$to} = 1 }
  push @to,$addto unless $to{$addto};
  # user has submitted with [select from your address book] ?
  # if ($submit and @to == 1) { $addto = '' }
}

$to = join(',',@to);

if ($from eq $to and $fex_yourself =~ /^no|0$/i) {
  http_die("fexing to yourself is not allowed");
}

$uid = randstring(8) unless $uid; # upload ID

# user requests for forgotten ID
if ($id_forgotten and $mail_authid and not ($fop_auth or $nomail)) {
  &check_status($from);
  &id_forgotten;
  exit;
}

# public recipients? (needs no auth-ID for sender)
if ($to and $id and $id eq 'PUBLIC' and @public_recipients) {

  unless ($from) {
    http_die("missing sender email address");
  }
  # must use $param{FROM} for checking because $from is expanded with $mdomain
  unless (checkaddress(despace($param{FROM}))) {
    http_die("$param{FROM} is not a valid email address");
  }
  foreach my $to (@to) {
    unless (grep /^\Q$to\E$/i,@public_recipients) {
      http_die("$to is not a valid recipient");
    }
  }
  $restricted = $public = $rid = $id;
  $akey = '';
}

# anonymous upload?
if (not $share and $from =~ /^anonymous@/) {
  unless (@anonymous_upload) {
    http_die("anonymous usage is not allowed");
  }
  unless (ipin($RA,@anonymous_upload)) {
    http_die("anonymous upload from your ip $RA is not allowed");
  }
  $id = $rid = $anonymous = 'anonymous';
  if ($to =~ /^anonymous/) {
    @to = ($to);
    $autodelete{$to} = $autodelete = $specific{'autodelete'}||'NO';
  }
  $nomail = $anonymous;
  $akey = '';
}

$comment = 'NOMAIL' if $nomail and not $comment;

# one time token
if ($okey) {
  $to = "@to" or http_die("no recipient specified");
  $from = readlink("$to/\@OKEY/$okey")
    or http_die("no upload key \"<code>$okey</code>\" - ".
                "request another one from $to");
  $from = untaint($from);
  $akey = '';
}

$nomail = $http_client if $http_client =~ /fexsync/;

check_status($from) if $from;

# check regular ID
if ($from and $id and
    not ($public||$anonymous||$gkey||$skey||$ukey||$okey||$pkey))
{
  $rid = readline1("$from/@")||'';
  if ($rid and sidhash($rid,$id) eq $id) {
    $fulluser = $from;
    # set time mark for successfull access
    my $time = untaint(time);
    utime $time,$time,$from;
    $akey = genakey($from); # needed for fexsend commands, too!
    $captive = -e "$from/\@CAPTIVE";
  } else {
    fuplog("ERROR: wrong auth-ID for $from");
    debuglog("id sent by user $from=$id, real id=$rid");
    faillog("user $from, id $id");
    if ($from and $mail_authid and -f "$from/@" and not ($fop_auth or $nomail)) {
      http_header('200 OK','Content-Type: text/html');
      print html_header($head);
      pq(qq(
        "<h1>ERROR: wrong auth-ID</h1>"
        'I have lost my auth-ID!'
        '<a href="/fup?from=$from&id=?">Mail it</a> to $from!\n'
      ));
      exit;
    } else {
      http_die("wrong user or auth-ID");
    }
  }
}

if ($ukey and $ukey =~ /^_/ and $ENV{REQUEST_METHOD} eq 'GET') {
  http_header('200 OK','Content-Type: text/plain');
  print "FUP=$ENV{PROTO}://$ENV{HTTP_HOST}/fup?ukey=$ukey;\n";
  if ($ukey =~ /_$/) {
    # for xxx
    pq(q(
      'xup() {'
      '  local c t;'
      '  [ -t 0 -a ! -r "$1" ] && { echo "usage: xup FILE..."; echo "usage: ... | xup"; return; };'
      '  c="[$(id -nu)@$(hostname)] ${@:--}";'
      '  t="${TMPDIR:-/tmp}/xxx_$(date +%Y%m%d_%H%M%S)";'
      '  [ -t 0 ] && { t="$t.tar"; echo $t:; tar cvf "$t" "$@"; } || { t="$t.gz"; gzip > "$t"; };'
      '  [ $? = 0 ] && curl -F "keep=1" -F "comment=$c" -F "file=@$t" $FUP|cat;'
      '  rm "$t";'
      '}; xup'
    ));
  } else {
    pq(q(
      'fup() {'
      '  local o c a t;'
      '  [ "$1" = -h ] && { echo "usage: fup [\"CURL-OPTIONS\"] FILE..."; return; };'
      '  while [[ "$1" =~ ^- ]]; do o="$o $1"; shift; done;'
      '  [ -r "$1" ] || { echo "usage: fup FILE..."; return; };'
      '  c="[$(id -nu)@$(hostname)]";'
      '  [ -z "$2" ] && [[ "$1" =~ \.(tar|tgz|tar\.gz|zip)$ ]] &&'
      '  { curl $o -F "keep=1" -F "comment=$c" -F "file=@$1" $FUP|cat; return; };'
      '  a=$(basename "$1");'
      '  [ -n "$2" ] && { echo -n "archive name: "; read a; };'
      '  t="${TMPDIR:-/tmp}/fup_$a.tar";'
      '  echo $t:;'
      '  tar cvf "$t" "$@" &&'
      '  curl $o -F "keep=1" -F "comment=$c" -F "file=@$t" $FUP|cat;'
      '  rm "$t";'
      '}; fup'
    ));
  }
  exit;
}

if ($share) {
  $share =~ s/\s//g;
  if ($share !~ /^[\w-]+$/) {
    http_die("illegal share name");
  }
  unless ($from) {
    http_die("sender needed for share");
  }
  unless (@to) {
    http_die("owner needed for share");
  }
  $share = untaint($share);
  $to = "@to";
  if ($to =~ /\@.*\@/) {
    http_die("sharing not allowed with multiple owners");
  }
  unless (checkaddress($to)) {
    http_die("$to is not a valid email address");
  }
  $autodelete{$to} = 'no';

  my $sharing = readlink_("$to/\@ARCHIVE_SHARING");
  if ($sharing =~ /no/i or not $archive_sharing and $sharing !~ /yes/i) {
    http_die("archive sharing is not allowed");
  }

  $owner = $to;
  $shared = "$to/SHARE/$share";

  if ($pkey) {
    &check_pkey;
    my $access = readlink("$shared/users/$from/access")||'read';
    $access = 'owner' if $to eq $from;
    if ($file) {
      if ($access eq 'read') {
        http_die("no write access for $to/$share/$from");
      }
      # archive can be given as URI parameter
      unless ($archive) {
        $file =~ /^(.+)_($vp\.(tar|tgz|zip|7z|gz))$/;
        $archive = $1 // '';
        $avt = $2 // '';
      }
      if ($access eq 'write' and not
          (length($archive) and -d "$shared/archives/$archive"))
      { http_die("no write access for $to/$share/$from/$file") }
    }
  } elsif ($to eq $from and $fulluser) {
    if ($file and not $archive) {
      $file =~ /^(.+)_($vp\.(tar|tgz|zip|7z|gz))$/;
      $archive = $1 // '';
      $avt = $2 // '';
    }
  } else {
    http_die("PKEY missing (from=$from to=$to)");
  }

  if ($file) {
    # no archive version and container type given?
    unless ($avt) {
      $file =~ s/\.tar\.gz$/.tgz/;
      $archive ||= $file;
      $archive =~ s/[^\w.+-]/_/g;
      $archive =~ s:^\.:_:;
      $archive = untaint($archive);
      my $container = 'zip';
      if ($file =~ s/\.(tar|tgz|zip|7z)$//) {
        $container = $1;
        $archive =~ s/\.(tar|tgz|zip|7z)$//;
      } else {
        # filename for zip archiving after upload (not zip filename!)
        $azip = $file;
        $azip =~ s:/:_:g;
        $azip = untaint($azip);
      }
      my @d = gmtime(time());
      $avt = sprintf('%d%02d%02d_%02d%02d%02d.%s',
                     $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0],$container);
    }
    if ($archive !~ /^[\w.+-]+$/) {
      http_die("illegal filename for archive sharing");
    }
  }
}

# optional $auth_hook() in fup.pl
if ($auth_hook and ($akey||$skey||$gkey||$ukey) and $from and -d $from) {
  &$auth_hook;
}

if ($from and $fulluser and not $restricted) {

  if ($command =~ /^DOX/) {
    my $doxua = readlink_("$from/\@DOCUMENT_EXCHANGE");
    if ($doxua eq 'no' or not $document_exchange and $doxua ne 'yes') {
      http_die('DOX not allowed');
    }
  }

  if ($command =~ /^DOXSYNC:([^\s\/]+):([^\s\/]+)/) {
    my $owner = $1;
    my $folder = $2;
    my $sync = '';
    my $fexsync = $ENV{FEXHOME}.'/bin/fexsync';

    if ($mdomain and -d "$owner\@$mdomain/DOX") {
      $owner .= '@'.$mdomain;
    }

    if ($from ne $owner) {
      http_die("DOX users are not yet supported");
    }

    if ("/$folder" =~ m:/\.: or $folder =~ /[<>|]/) {
      http_die("illegal DOX directory");
    }

    if ($from eq $owner and $folder =~ s/:DELETE$//) {
      my $dd = "$owner/DOX/$folder";
      rmrf($dd);
      if (-d $dd) {
        http_die("cannot delete $folder");
      } else {
        http_header('222 OK');
      }
      exit;
    }

    $folder =~ s/:COMPRESS$// and $fexsync .= ' -z';

    # my $tkey = sprintf "%06d",int(rand(1000000));

    my $df = "$owner/DOX/$folder";
    chdir $df or http_die("no such DOX directory");
    debuglog("cd $df");
    debuglog("$fexsync .");
    local $ENV{FEXCOMMENT} = $df;
    local $ENV{FEXSERVER} = '';

    my $log = sprintf "../%s_fexsync_%s.log",$folder,time;
    # tee is needed for process timing!
    open $fexsync,"$fexsync . 2>&1|tee $log|"
      or http_die("cannot run fexsync - $!");

    while (<$fexsync>) {
      debuglog($_);
      if (/^fexsync:/) {
        http_die($_);
      }
      if (/fexsync \Q$folder/) {
        s/:\d+/:$ENV{PORT}/;
        $sync = $_;
        last;
      }
    }

    unless ($sync) {
      http_die("fexsync failed");
    }

    http_header(
      '222 OK',
      'Content-Type: text/plain',
    );

    print $sync;
    shutdown(STDOUT,2);
    close STDOUT;

    while (<$fexsync>) { }
    exit;
  }

  if ($command =~ /^DOXDEL:([^\s\/]+)+$/) {
    my $owner = $from;
    my $folder = $1;
    my $dd = "$owner/DOX/$folder";

    if (-d $dd) {
      rmrf($dd);
    } else {
      http_die("no DOX directory $folder");
    }

    if (my @v = grep /\/\Q$folder\E_$vp$/,glob "${dd}_*") {
      foreach my $v (@v) {
        rmrf(untaint($v));
      }
    }

    if (-d $dd) {
      http_die("deleting of $dd failed - $!");
    } else {
      http_header(
        '222 OK',
        'Content-Type: text/plain',
      );
      print "DOX directory $folder removed\n";
    }
    close STDOUT;
    doxdu($owner);
    exit;
  }

  if ($command eq 'DOXLIST') {
    my $owner = $from;

    chdir "$owner/DOX" or http_die("no DOX directory");

    http_header(
      '222 OK',
      'Content-Type: text/plain',
    );

    my $dox = sprintf "%s://%s/dox/%s",
              $ENV{PROTO},($ENV{HTTP_HOST}||$ENV{SERVER_NAME}),$owner;
    $dox =~ s/:443// if $ENV{PROTO} eq 'https';
    print "$dox/\n";

    alarm(0);
    foreach (glob '.*.du') {
      if (-l and /^\.(\S+)\.du$/ and -d $1) {
        my $folder = $1;
        my $du = readlink;
        printf "%s %s %s\n",mtime($folder),int($du/1024),$folder;
      }
    }

    exit;
  }

  if ($command =~ /^DOXLIST:([^\s\/]+)+$/) {
    my $owner = $from;
    my $folder = $1;
    my $dd = "$owner/DOX/$folder";

    chdir $dd or http_die("no DOX directory $folder");

    http_header(
      '222 OK',
      'Content-Type: text/plain',
    );

    my $dox = sprintf "%s://%s/dox/%s",
              $ENV{PROTO},($ENV{HTTP_HOST}||$ENV{SERVER_NAME}),$owner;
    $dox =~ s/:443// if $ENV{PROTO} eq 'https';
    print "$dox/$folder\n";

    foreach (asort(find('.'))) {
      if ((-l or -f) and my @s = lstat) {
        s:./::;
        printf "%d %s\n",$s[9],hexencode($_);
      }
    }

    exit;
  }

  # create one day UKEY
  if ($command eq 'GENUKEY') {
    my $ukey = randstring(8);
    $ukey = '_'.$ukey     if $http_client =~ /^fexpack/;
    $ukey = '_'.$ukey.'_' if $http_client =~ /^xxx/;
    symlink $from,"$ukeydir/$ukey"
      or http_die("cannot create UKEY $ukey - $!\n");
    if ($http_client =~ /fex/) {
      http_header(
        '200 OK',
        "X-UKEY: $ukey",
        'Content-Type: text/plain',
      );
      print "$ukey\n";
      exit;
    } else {
      nvt_print(
        "HTTP/1.1 302 Found",
        "Location: /fup?ukey=$ukey",
        'Content-Length: 0',
        ""
      );
      # control back to fexsrv for further HTTP handling
      &reexec;
    }
  }

  # generate onetime upload key and show URL
  if ($command =~ /^GENOKEY:(\S+)/) {
    my $user = $1;
    my $okey = randstring(8);
    my $okeyd = "$spooldir/$from/\@OKEY";

    unless ($user =~ /@/ and checkaddress($user)) {
      http_die("$user is not a valid email address");
    }

    mkdir $okeyd;
    symlink $user,"$okeyd/$okey"
      or http_die("cannot create OKEY $okeyd/$okey - $!");

    nvt_print(
      'HTTP/1.0 200 OK',
      "Server: fexsrv",
      "X-okey: $okey",
      "Content-Type: text/plain",
      ''
    );

    print "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?to=$from?okey=$okey\n";
    exit;
  }
}

# forward a copy of a file to another recipient
if (($akey or $fulluser) and $dkey and $command eq 'FORWARD') {
  my $file = untaint(readlink_("$dkeydir/$dkey"));
  http_die("unknown dkey <code>$dkey></code>") unless $file;
  $file =~ s:^\.\./::;
  forward($file);
  exit;
}

# modify file parameter
if ($akey and $dkey and $command eq 'MODIFY') {
  my $file = untaint(readlink_("$dkeydir/$dkey")) or
    http_die("unknown dkey <code>$dkey</code>");
  $file =~ s:^\.\./::;
  modify($file);
  exit;
}

# copy file from incoming to outgoing spool
if ($akey and $dkey and $command eq 'COPY') {
  unless ($file = readlink("$dkeydir/$dkey")) {
    http_die("no such file with DKEY=$dkey");
  }
  if ($file =~ m:../(.+)/(.+)/(.+):) {
    ($to,$from,$file) = ($1,$2,$3);
  } else {
    http_die("bad DKEY $dkey -> $file");
  }
  unless (-f "$to/$from/$file/data") {
    http_die("file not found");
  }
  if (-e "$to/$to/$file/data") {
    http_die("file $file already exists in your outgoing spool")
      if (readlink("$to/$to/$file/id")||$to) ne
         (readlink("$to/$from/$file/id")||$from);
  } else {
    mkdirp("$to/$to/$file");
    link "$to/$from/$file/data","$to/$to/$file/data"
      or http_die("cannot link to $to/$to/$file/data - $!\n");
    copy("$to/$from/$file/filename","$to/$to/$file/filename");
    copy("$to/$from/$file/id","$to/$to/$file/id");
    open $file,'>',"$to/$to/$file/notify";
    close $file;
    open $file,'>',"$to/$to/$file/download";
    print {$file} "$to\n";
    close $file;
    $dkey = randstring(8);
    unlink "$to/$to/$file/dkey","$to/$to/$file/keep","$dkeydir/$dkey";
    symlink "../$to/$to/$file","$dkeydir/$dkey";
    symlink $dkey,"$to/$to/$file/dkey";
  }
  nvt_print(
    "HTTP/1.1 302 Found",
    "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/rup?oto=$to&file=$file",
    'Content-Length: 0',
    ''
  );
  # control back to fexsrv for further HTTP handling
  &reexec;
}

# delete file without download
if ($akey and $dkey and $command eq 'DELETE') {
  $del = untaint(readlink_("$dkeydir/$dkey"));
  http_die("unknown dkey <code>$dkey</code>") unless $del;
  $del =~ s:^\.\./::;
  $filename = filename($del);
  if (unlink("$del/data") or unlink("$del/upload")) {
    if (open F,'>',"$del/error") {
      printf F "%s has been deleted by %s at %s\n",
               $filename,$ENV{REMOTE_ADDR},isodate(time);
      close F;
    }
    my $referer = $ENV{HTTP_REFERER}||'';
    if ($referer =~ m:/fas:) {
      nvt_print(
        "HTTP/1.1 302 Found",
        "Location: $referer",
        'Content-Length: 0',
        ""
      );
    } else {
      nvt_print(
        "HTTP/1.1 302 Found",
        "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup?command=LISTRECEIVED",
        'Content-Length: 0',
        ""
      );
    }
    # control back to fexsrv for further HTTP handling
    &reexec;
  } else {
    my $s = $!;
    http_header('404 Not Found');
    print html_header($head);
    print "<h3>$filename not deleted ($s)</h3>\n";
    print "<a href=\"/fup?command=LISTRECEIVED\">continue</a>\n" if $akey;
    print "</body></html>\n";
  }
  exit;
}

# ip restrictions
if ($from and open my $ipr,"$from/\@UPLOAD_HOSTS") {
  my @hosts;
  while (<$ipr>) {
    chomp;
    s/#.*//;
    push @hosts,$_ if /\w/;
  }
  close $ipr;
  unless (@hosts and ipin($RA,@hosts)) {
    http_die("$from is not allowed from IP $RA");
  }
}

# special commands
if (($fulluser or $gkey or $skey) and $command) {

  if ($command eq 'CHECKQUOTA') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    nvt_print('HTTP/1.1 222 OK');
    # nvt_print("X-SID: $ENV{SID}") if $ENV{SID};
    my ($quota,$du) = check_sender_quota($muser||$from);
    nvt_print("X-Sender-Quota: $quota $du")    if $quota;
    ($quota,$du) = check_recipient_quota($muser||$from);
    nvt_print("X-Recipient-Quota: $quota $du") if $quota;
    nvt_print('');
    exit;
  }

  if ($command eq 'LISTSETTINGS') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    nvt_print('HTTP/1.1 222 OK');
    # nvt_print("X-SID: $ENV{SID}") if $ENV{SID};
    my ($quota,$du) = check_sender_quota($muser||$from);
    nvt_print("X-Sender-Quota: $quota $du")    if $quota;
    ($quota,$du) = check_recipient_quota($muser||$from);
    nvt_print("X-Recipient-Quota: $quota $du") if $quota;
    $autodelete = lc(readlink("$from/\@AUTODELETE") || $autodelete);
    nvt_print("X-Autodelete: $autodelete");
    $keep = readlink("$from/\@KEEP") || $keep;
    nvt_print("X-Default-Keep: $keep");
    $locale = readlink("$from/\@LOCALE") || $default_locale || 'english';
    nvt_print("X-Default-Locale: $locale");
    $mime = -e "$from/\@MIME" ? 'yes' : 'no';
    nvt_print("X-MIME: $mime");
    nvt_print('');
    exit;
  }

  if ($command eq 'RENOTIFY') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    my $nfile = '';
    if ($dkey) {
      # resend notification email
      $file = readlink("$dkeydir/$dkey")
        or html_error($error,"illegal DKEY $dkey");
      $file =~ s:^../::;
      $file = untaint($file);
      unlink "$file/download"; # re-allow download from any ip address
      notify_locale($dkey,'new');
      http_header(
        '200 OK',
        "X-Notify: $file",
      );
      $nfile = $file;
    } else {
      http_header('200 OK');
    }
    print html_header($head);
    # list sent files
    print "<h3>Files from $from, ",
          "click on the file name to resend a notification email:</h3>\n",
          "<pre>\n";
    foreach $file (glob "*/$from/*") {
      next if $file =~ m:/STDFEX$:;
      next if $file =~ m:(.+?)/: and -l $1;
      $size = -s "$file/data";
      next unless $size;
      $size = int($size/$MB+0.5);
      $filename = $comment = '';
      my $rto = $file;
      $rto =~ s:/.*::;
      if ($dkey = readlink("$file/dkey")) {
        if ($rto ne $to) {
          $to = $rto;
          print "\nto $to :\n";
        }
        if (open $file,'<',"$file/filename") {
          $filename = <$file>;
          close $file;
        }
        if ($filename and length $filename) {
          $filename = htmlquote($filename);
        } else {
          $filename = '???';
        }
        if (open $file,'<',"$file/comment") {
          $comment = untaint(htmlquote(getline($file)));
          close $file;
        }
        my $rkeep = untaint(readlink("$file/keep")||$keep_default)
                    - int((time-mtime("$file/filename"))/$DS);
        if ($comment =~ /NOMAIL/ or
            readlink_("$to/\@NOTIFICATION") =~ /^no/i) {
          printf "%8s MB (%2s d) %s/%s/%s\n",
                 $size,
                 $rkeep,
                 $durl,
                 $dkey,
                 urlencode(basename($file));
        } else {
          printf "%8s MB (%2s d) <a href=\"%s\">%s</a>%s %s\n",
                 $size,
                 $rkeep,
                 untaint("/fup?dkey=$dkey&command=RENOTIFY"),
                 $filename,
                 $comment ? qq' "$comment"' : '',
                 $file eq $nfile ?
                   " &rarr; notification email has been resent" :
                   "";
        }
      }
    }
    pq(qq(
      '</pre>'
      '<p><a href="/foc">back to F*EX operation control</a>'
      '</body></html>'
    ));
    exit;
  }

  if ($command =~ /^LIST(RECEIVED)?$/) {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    # list sent files
    if ($to and $param{'TO'} eq '*') {
      http_header('200 OK');
      print html_header($head);
#            "(Format: [size] [rest keep time] [filename] [comment])<p>\n",
      print "<h3>Files from $from:</h3>\n",
            "<pre>\n";
      foreach $file (glob "*/$from/*") {
        next if $file =~ m:/STDFEX$:;
        next if $file =~ m:(.+?)/: and -l $1;
        next if readlink_("$file/data") eq 'upload';
        $size = -s "$file/data";
        next unless $size;
        $size = int($size/$MB+0.5);
        $filename = $comment = '';
        my $rto = $file;
        $rto =~ s:/.*::;
        if ($dkey = readlink("$file/dkey")) {
        # die $file if -s "$file/data" and $file =~ /^$from/;
          if ($rto ne $to) {
            $to = $rto;
            print "\nto $to :\n";
          }
          if (open $file,'<',"$file/filename") {
            $filename = <$file>;
            close $file;
          }
          if ($filename and length $filename) {
            $filename = htmlquote($filename);
          } else {
            $filename = '???';
          }
          if (open $file,'<',"$file/comment") {
            $comment = untaint(htmlquote(getline($file)));
            close $file;
          }
          my $rkeep = untaint(readlink("$file/keep")||$keep_default)
                      - int((time-lmtime("$file/keep"))/$DS);
          printf "%8s MB (%3s d) %s <a href=\"%s\">%s</a>%s\n",
                 $size,
                 $rkeep,
                 stat("$file/download")?'+':'-',
                 untaint("/fup?dkey=$dkey&command=FORWARD"),
                 $filename,
                 $comment?qq( "$comment"):'';
        }
      }
      pq(qq(
        '</pre>'
        '<p><a href="$back">back to F*EX operation control</a>'
        '</body></html>'
      ));
    }
    # list received files
    else {
      $to = $from;
      http_header('200 OK');
      print html_header($head);
#            "(Format: [size] [rest keep time] [URL] [comment])<p>\n",
      print "<h3>Files for $to (*):</h3>\n",
            "<pre>\n";
      foreach $from (glob "$to/*") {
        next if $from =~ /[A-Z]/;
        $from =~ s:.*/::;
        $url = '';
        foreach $file (glob "$to/$from/*") {
          next if $file =~ /\/STDFEX$/;
          next if readlink_("$file/data") eq 'upload';
          $filename = $comment = '';
          $size = -s "$file/data";
          next unless $size;
          $size = int($size/$MB+0.5);
          if ($dkey = readlink("$file/dkey")) {
            print "\nfrom $from :\n" unless $url;
            $file =~ m:.*/(.+):;
            $url = "$durl/$dkey/$1";
            unless (-l "$dkeydir/$dkey") {
              symlink untaint("../$file"),untaint("$dkeydir/$dkey");
            }
            if (open $file,'<',"$file/filename") {
              $filename = <$file>;
              close $file;
            }
            if ($filename and length $filename) {
              $filename = htmlquote($filename);
            } else {
              $filename = '???';
            }
            if (open $file,'<',"$file/comment") {
              $comment = untaint(htmlquote(getline($file)));
              $comment = ' "'.$comment.'"';
              close $file;
            }
            my $rkeep = untaint(readlink("$file/keep")||$keep_default)
                        - int((time-mtime("$file/filename"))/$DS);
            printf "[<a href=\"/fup?akey=%s&dkey=%s&command=DELETE\">delete</a>] ",
                   $akey,$dkey;
            printf "[<a href=\"/fup?akey=%s&dkey=%s&command=COPY\">forward</a>] ",
                   $akey,$dkey;
            printf "%8s MB (%3s d) <a href=\"%s\">%s</a>%s\n",
                   $size,$rkeep,$url,$filename,$comment;
          }
        }
      }
      pq(qq(
        '</pre>'
        '(*) Files for other email addresses you own will not be listed here!<p>'
        '<a href="/foc">back to F*EX operation control</a>'
        '</body></html>'
      ));
    }
    exit;
  }

  if ($command eq 'LISTSENT') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    # show download URLs
    http_header('200 OK');
    print html_header($head);
    print "<h2>Download URLs of files you have sent\n";
    foreach $to (glob "*/$from") {
      if (@files = glob "$to/*/data") {
        $to =~ s:/.*::;
        print "<h3>to $to :</h3>\n";
        print "<pre>\n";
        foreach $file (@files) {
          $file =~ s:/data::;
          next if $file =~ /\/STDFEX$/;
          $dkey = readlink("$file/dkey") or next;
          $file =~ s:.*/::;
          print "$ENV{PROTO}://$ENV{HTTP_HOST}/fop/$dkey/$file\n";
        }
        print "</pre>\n";
      }
    }
    pq(qq(
      '</pre>'
      '<p><a href="$back">back to F*EX operation control</a>'
      '</body></html>'
    ));
    exit;
  }

  if ($command eq 'FUPWATCH') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    http_header(
      '222 OK',
      'Content-Type: text/plain',
    );
    alarm(0);
    $| = 1;
    exec "$FEXHOME/bin/fupwatch",$from or
    http_die("cannot run fupwatch : $!");
  }

  if ($command eq 'FOPLOG') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    if (open my $log,"$logdir/fop.log") {
      http_header('200 OK');
      while (<$log>) {
        next if /\/STDFEX\s/;
        if (s:^([^/]+)/$from/:$1 :) {
          if (s:(\d+)/(\d+)$:$1: and $1 and $1 == $2) {
            s/ \[[\d_]+\]//;
            print;
          }
        }
      }
    }
    exit;
  }

  if ($command eq 'RECEIVEDLOG') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    if (open my $log,"$logdir/fup.log") {
      http_header('200 OK');
      while (<$log>) {
        next if /\sSTDFEX\s/;
        if (/\d+$/) {
          my @F = split;
          if ($F[5] eq $to) {
            s/ \[[\d_]+\]//;
            print;
          }
        }
      }
    }
    exit;
  }

  if ($command eq 'SENDLOG') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    if (open my $log,"$logdir/fup.log") {
      http_header('200 OK');
      while (<$log>) {
        next if /\sSTDFEX\s/;
        if (/(\S+\@\S+)/ and $1 eq $from) {
          s/ \[[\d_]+\]//;
          print;
        }
      }
    }
    exit;
  }

  if (@to and $command eq 'CHECKRECIPIENT') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    check_rr($from,@to);
    nvt_print('HTTP/1.1 204 OK');
    nvt_print("X-SID: $sid") if $sid;
    foreach my $to (@group?@group:@to) {
      my $options = sprintf "(autodelete=%s,keep=%s,locale=%s)",
        $autodelete{$to}||$autodelete,
        $keep{$to}||$keep_default,
        readlink("$to/\@LOCALE")||$locale{$to}||$default_locale;
      nvt_print("X-Recipient: $to $options");
    }
    nvt_print('');
    # control back to fexsrv for further HTTP handling
    &reexec;
  }

  if ($file and @to and $command eq 'DELETE') {
    http_die("illegal command \"$command\"") if $public or $anonymous;
    http_die("subuser cannot delete")        if $from eq 'SUBUSER';
    foreach (@group?@group:@to) {
      my $to = $_;
      $to =~ s/:\w+=.*//; # remove options from address
      $del = "$to/$from/$fkey";
      # swap to and from for special senders, see fup storage swap!
      $del = "$from/$to/$fkey" if $from =~ /^(fexmail|anonymous)/;

      $del =~ s:^/+::;
      if ($del =~ /\/\./) {
        http_die("illegal parameter <code>$del</code>");
      }
      $del = untaint($del);

      if (unlink("$del/data") or unlink("$del/upload")) {
        if (open F,'>',"$del/error") {
          print F "$file has been deleted by $from\n";
          close F;
        }
        http_header('200 OK',"X-File: $del");
        print html_header($head);
        print "<h3>$file for $to deleted</h3>\n";
      } else {
        http_header("404 Not Found");
        print html_header($head);
        print "<h3>$file not deleted</h3>\n";
      }
      if ($akey) {
        printf "<a href=\"/fup?akey=%s&to=%s&command=LISTRECEIVED\">continue</a>\n",
               $akey,$to;
      }
      print "</body></html>\n";
    }
    exit;
  }

}

# list shares
if ($fulluser and $command eq 'LISTSHARES') {
  my $sharing = readlink_("$from/\@ARCHIVE_SHARING");
  if ($sharing =~ /no/i or not $archive_sharing and $sharing !~ /yes/i) {
    http_die("archive sharing is not allowed");
  }

  http_header(
    '200 OK',
    'Content-Type: text/plain',
  );
  print "_\n";
  foreach (
    sort { lc $a cmp lc $b }
    grep { s:.*/(.+)/.*:$1: }
    glob "$from/SHARE/*/archives"
  ) {
    print "$_\n" unless /^_$/;
  }
  exit;
}

# copy share archive
if ($fulluser and
    $command =~ /^COPYARCHIVE:([\w-]+):([\w.+-]+):($vp\.\w+):(.+):(.+)/)
{
  my $share = $1;
  my $archive = $2;
  my $avt = $3;
  my $nshare = $4;
  my $narchive = $5;
  my $shared = "$from/SHARE";
  my $sharing = readlink_("$from/\@ARCHIVE_SHARING");
  if ($sharing =~ /no/i or not $archive_sharing and $sharing !~ /yes/i) {
    http_die("archive sharing is not allowed");
  }
  $nshare =~ s/[^\w-]/_/g;
  $narchive =~ s/[^\w.+-]/_/g;
  unless (-d "$shared/$share") {
    http_die("unknown share $share");
  }
  unless (-d "$shared/$nshare" or mkdir "$shared/$nshare") {
    http_die("cannot mkdir share $nshare - $!\n");
  }
  my $ad = "$shared/$share/archives/$archive/$avt";
  my $nad = "$shared/$nshare/archives/$narchive/$avt";
  if (-d $nad) {
    http_die("archive $nshare:$narchive:$avt does already exist\n");
  }
  mkdirp($nad);
  unless (-d $nad) {
    http_die("cannot create $nshare:$narchive:$avt - $!\n");
  }
  my $rr = `rsync -a --exclude data $ad $nad/../ 2>&1`;
  if ($rr =~ /\w/) {
    http_die($rr);
  }
  unlink "$nad/download","$nad/dkey";
  unless (link "$ad/data","$nad/data") {
    http_die("cannot link $nad/$ndata - $!\n");
  }
  if ($nshare eq '_') {
    my $dkey = randstring(8);
    symlink "../$nad","$dkeydir/$dkey" and
    symlink $dkey,"$nad/dkey";
  }
  faslog("$shared/$nshare","$from copied $share:$archive:$avt to $narchive");
  http_header(
    '200 OK',
    'Content-Type: text/plain',
  );
  print "$share:$archive:$avt copied to $nshare:$narchive\n";
  exit;
}

if ($share and $command) {
  my $sx = '';
  my $access = '';
  my @list;

  if ($from eq $to and $fulluser) {
    $access = 'owner';
    $sx = md5_hex("$1:$rid") if $id =~ /^MD5H:(\w+)/;
  } elsif ($pkey and $access = readlink("$shared/users/$from/access")) {
    if ($access eq 'manage' and $pkey =~ /^MD5H:(\w+)/) {
      $sx = md5_hex("$1:".readline1("$shared/users/$from/pkey"))
    }
  } else {
    http_die("no access");
  }

  # list share with users and archives
  if ($command eq 'LISTSHARE') {
    http_header(
      '200 OK',
      'Content-Type: text/plain',
      "X-Access: $access",
    );
    print "access=$access\n";
    # list users
    if ($access eq 'owner' or $access eq 'manage') {
      print "$to:owner:-\n";
      foreach my $u (glob("$shared/users/*")) {
        if (-d $u) {
          my $up = readline1("$u/pkey") or next;
          my $ua = readlink_("$u/access");
          $up = unpack("H*",$up ^ $sx) if $sx;
          printf "%s:%s:%s\n",basename($u),$ua,$up;
        }
      }
    }

    @list = ();
    # list writable archive sets
    if ($access ne 'read') {
      foreach my $a (glob("$shared/archives/*")) {
        if (-d $a) {
          push @list,sprintf("%s\n",basename($a));
        }
      }
    }
    print _sort(@list);

    @list = ();
    $sx = substr($sx,0,8);
    # list available archives
    foreach my $a (glob("$shared/archives/*/*/data")) {
      my $utime = mtime($a);
      $a =~ s:/data$::;
      $a =~ m:.*/(.+)/(.+):;
      my $archive = $1;
      my $avt = $2;
      my $size = -s "$a/data";
      my $uploader = readlink("$a/uploader")||$to;
      my $comment = readline1("$a/comment")||'';
      my $dkey = readlink_("$a/dkey");
      my $xdkey = '';
      if ($id and $dkey and -l "$dkeydir/$dkey") {
        if ($sx) {
          $xdkey = unpack("H*",$dkey ^ $sx);
        } else {
          $xdkey = $dkey;
        }
      }
      push @list,sprintf(qq'%s %s %d %d %s "%s" %s\n',
        $archive,$avt,$utime,$size,$uploader,$comment,$xdkey);
    }
    print _sort(@list);
    exit;
  }

  # add or modify share user
  if ($command =~ '^SHAREUSER:([^\s\/]+):([a-z]+)$') {
    my $suser = lc $1;
    my $access = $2;
    my $shared = "$to/SHARE/$share";
    if ($suser !~ /^\w[\w~!_.=+-]*\@[\w.-]+\.[a-z]+$/) {
      http_die("illegal user $suser");
    }
    unless ($from eq $to and $fulluser) {
      if (readlink_("$shared/users/$from/access") ne 'manage') {
        http_die("no manage access for $to/$share/$from");
      }
      if ($access eq 'manage') {
        http_die("you are not the owner and cannot set manage access right");
      }
    }
    my $suserd = "$shared/users/$suser";
    if ($access eq 'none') {
      rmrf($suserd);
      http_header(
        '200 OK',
        'Content-Type: text/plain',
      );
      print "$to/$share/$suser removed\n";
      faslog($shared,"$from removed user $suser");
    } else {
      mkdirp($suserd);
      mksymlink("$suserd/access",$access);
      my $pkey = '';
      my $pkf = "$suserd/pkey";
      if ($pkey = readline1($pkf)) {
        faslog($shared,"$from set access=$access for $suser");
      } else {
        $pkey = randstring(32);
        open $pkf,'>',$pkf or http_die("cannot create $pkf - $!\n");
        print {$pkf} $pkey,"\n";
        close $pkf;
        faslog($shared,"$from created $suser");
      }
      http_header(
        '200 OK',
        'Content-Type: text/plain',
      );
      $pkey = 'MD5H:'.unpack("H*",$pkey ^ $sx) if $sx;
      print "pkey=$pkey\n";
    }
    exit;
  }

  http_die("unknown command $command");
}

# quotas
if ($fulluser and @to and not $flink and not $seek) {

  # check sender quota
  my ($quota,$du) = check_sender_quota($muser||$from);
  if ($quota and $du+$cl/$MB > $quota) {
    if ($from and not $muser) {
      # remove aborted dox stream (stage 1 from fexdox)
      foreach my $ds (glob "$from/DOX/*!stream") {
        rmrf(untaint($ds));
      }
    }
    http_die("you are overquota");
  }

  # check recipient quota
  foreach my $to (@to) {
    ($quota,$du) = check_recipient_quota($to);
    if ($quota and $du+$cl/$MB > $quota) {
      http_die("$to cannot receive files: is overquota");
    }
  }

}

# check recipients restriction
if ($fulluser and @to and not $public) {
  check_rr($from,@to);
}

# on secure mode "fop authorization" also check if recipient(s) exists
# (= has a F*EX ID)
if (not $addto and $fop_auth and $fulluser and @to) {
  my ($to_reg,$idf,$subuser);
  foreach my $to (my @loop = @to) {
    $to =~ s/:\w+=.*//; # remove options from address
    $to_reg = 0;
    # full user?
    if (open $idf,'<',"$to/@") {
      $to_reg = getline($idf);
      close $idf;
    }
    # sub user?
    elsif (open $idf,'<',"$from/\@SUBUSER") {
      while (<$idf>) {
        s/#.*//;
        next unless /:/;
        chomp;
        ($subuser) = split ':';
        if ($subuser eq $to or $subuser eq '*@*'
            or $subuser =~ /^\*\@(.+)/ and $to =~ /\@\Q$1\E$/i
            or $subuser =~ /(.+)\@\*$/ and $to =~ /^\Q$1\E\@/i) {
          $to_reg = $_;
          last;
        }
      }
      close $idf;
    }
    unless ($to_reg) {
      http_die("recipient $to is not a registered F*EX full or sub user");
    }
  }
}

$to = join(',',@to);

if ($to =~ /^@(.+)/) {
  if ($nomail) {
    http_die("server runs in NOMAIL mode - groups ($to) are not allowed");
  }
  my $gf = "$from/\@GROUP/$1";
  if (open $gf,'<',$gf) {
    while (<$gf>) {
      s/#.*//;
      $keep = $1       if /^keep=(\d+)/i;
      $autodelete = $1 if /^autodelete=(yes|no)/i;
      push @group,$1   if /(.+@.+):/;
    }
  }
  close $gf;
  $group = $to;
}

if ($redirect) {
  nvt_print(
    "HTTP/1.1 302 Found",
    "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/$redirect",
    'Content-Length: 0',
    ""
  );
  # control back to fexsrv for further HTTP handling
  &reexec;
}

# on successful login, delete faillog
if ($fulluser and $faillog) {
  unlink $faillog;
}

# display HTML form and request user data
unless ($file) {

#  if ($fulluser and $RA and $http_client !~ /^fex/) {
#    mkdir '.login' unless -d '.login';
#    unlink ".login/$RA";
#    symlink $fulluser,".login/$RA";
#  }

  if ($test) { $cgi = $test }
  else       { $cgi = $ENV{SCRIPT_NAME} }
  $cgi = 'fup';

  # delete old cookies on logout referer
  my @cookies;
  if ($logout and my $cookie = $ENV{HTTP_COOKIE}) {
    while ($cookie =~ s/(\w+key)=\w+//) {
      push @cookies,"Set-Cookie: $1=x; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT";
    }
  }

  if (($akey or $skey or $gkey) and $from and -d $from) {
    # save default locale for this user
    if (not $locale and ($ENV{HTTP_COOKIE}||'') =~ /\blocale=(\w+)/) {
      $locale = $1;
    }
    mksymlink("$from/\@LOCALE",$locale) if $locale;
  }

  if (my $forward = $param{FORWARD} and $akey) {
    $forward =~ s:^/::;
    my $login = basename(readlink("$akeydir/$akey")||'');
    nvt_print(
      "HTTP/1.1 302 Found",
      "Location: /$forward",
      "Set-Cookie: locale=$locale",
      "Set-Cookie: akey=$akey; path=/; Max-Age=44444; Discard",
      "Set-Cookie: login=$login; path=/",
      'Expires: 0',
      'Content-Length: 0',
      ''
    );
    # control back to fexsrv for further HTTP handling
    &reexec;
  }

  http_header('200 OK',@cookies);
  # print html_header($head,'<img src="/fex_small.gif">');
  print html_header($head);

  if ($http_client =~ /(Konqueror|w3m)/) {
    pq(qq(
      '<p><hr><p>'
      '<center>'
      '<h3>Your client seems to be "$1" which is incompatible with F*EX and will probably not work!</h3>'
      'We recommend firefox or google chrome.'
      '</center>'
      '<p><hr><p>'
    ));
  }

  # default "fex yourself" setting?
  if ($fulluser and not $addto
      and not ($gkey or $skey or $okey or $public or $anonymous)
      and (not @to or "@to" eq $from)
      and -f "$from/\@FEXYOURSELF")
  {
    @to = ($from);
    $nomail = 'fexyourself';
  }

  # ask for recipient address(es)
  elsif ($fulluser and ($addto or not $submit or not @to)
         and not ($gkey||$skey||$okey||$ukey||$public||$anonymous))
  {
    present_locales('/fup');

    # print "[$addto] [$submit] [@to]<p>\n";

    @ab = ("<option></option>");

    # select menu from server address book
    if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
      while (<$AB>) {
        s/#.*//g;
        if (/(\S+)[=\s]+(\S+@[\w.-]+\S*)/) {
          $_ = "$1 &lt;$2>";
          s/,.*/,.../g;
          s/:.*/>/;
          push @ab,"<option>$_</option>";
        }
      }
      close $AB;
    }

    unless (@to) {
      unless ($nomail) {
        foreach (glob "$from/\@GROUP/*") {
          if (-f and not -l) {
            s:.*/::;
            push @ab,"<option>\@$_</option>" unless /~$/;
          }
        }
      }
    }

    my $ab64 = b64("from=$from&id=$id");
#     '<form class="uploadform" name="upload"'
    pq(qq(
      '<form name="upload" action="/fup" $formpara>'
      '  <input type="hidden" name="from" value="$from">'
      '  <input type="hidden" name="id"   value="$id">'
      '  <table border="1">'
      '    <tr><td>sender:   <td><a href="/foc">$from</a></tr>'
      '    <tr title="email address or alias"><td>recipient(s):'
      '        <td><input type="text" name="to" size="96" value="$to"><br>'
    ));
    if (grep /@/,@ab) {
      pq(qq(
        '        or select from your address book:'
        '        <select name="addto" size="1">@ab</select>'
        '        and'
        '        <input type="submit" name="addsubmit" value="add to recipients list">'
      ));
    }
    pq(qq(
      '    </tr>'
      '  </table>'
      '  <p>'
    ));
    my $rr = "$from/\@ALLOWED_RECIPIENTS";
    if (-s $rr and open $rr,'<',$rr) {
      pq(qq(
        'You are a restricted user and may only fex to these recipients:<p>'
        '<pre>'
      ));
      while (<$rr>) {
        chomp;
        s/#.*//;
        s/\s//g;
        next unless $_;
        if (/^\@LOCAL_RDOMAINS/) {
          foreach my $rd (@local_rdomains) {
            print "*\@$rd\n";
          }
        } elsif (/^\@LOCAL_USERS/) {
          foreach (glob "*/@") {
            s:/.::;
            print "$_\n";
          }
        } else {
          print "$_\n";
        }
      }
      print "</pre><p>\n";
      close $rr;
    }
    print qq'  <input type="submit" name="submit" value="check recipient(s) and continue">';
    if ($fex_yourself =~ /^yes|1/i) {
      print qq' or <input type="submit" name="fexyourself" value="fex yourself">'
    }
    print "\n</form>\n";
    if ($akey and -f "$from/@" and not ($captive or $ukey)) {
      pq(qq(
        '<p>'
        '<a href="/foc">user config & operation control</a>'
      ));
    }

    if ($from eq $admin ) {
      pq(qq(
        '<p>'
        '<a href="/fac">server config & admin control</a>'
      ));
    }

    print &logout;
    pq(qq(
      '<p><hr><p>'
      '<b>'
      'Warning: the recipient must not be a mailing list,'
      'because after download the file will be no more available!'
      '</b><br>'
      'Contact <a href="mailto:$ENV{SERVER_ADMIN}">fexmaster</a> if you want to fex to a mailing list,'
      'he can allow multiple downloads for specific addresses.'
      '<p>'
      'Use a <a href="/tools.html">F*EX client</a> if you want to send more than one file or resume an interrupted upload.'
      '</body></html>'
      '<p>'
   ));
    print $info_1;
    exit;
  }

  # ask for filename
  if ($from and ($id or $okey or $pkey)) {
    $to = $group if $group;
    present_locales($ENV{REQUEST_URI}) if $skey or $gkey;
    pq(qq(
      '<script>'
      '  function showstatus() {'
      '    var file = document.forms["upload"].elements["file"].value;'
      '    if (file == "") return false;'
      '    window.open('
      "      '/$cgi?showstatus=$uid',"
      "      'fup_status',"
      "      'width=700,height=500'"
      '    );'
      '    return true;'
      '  }'
      ''
      '  function checkupload() {'
      '    var file  = document.forms["upload"].elements["file"].value;'
      '    if (file == "") { alert("No file selected") }'
      '  }'
      ''
      '  function reportsize() {'
      '    var form = document.forms["upload"];'
      '    var filesize = form.file.files[0].size;'
      '    // alert(filesize + " bytes");'
      '    form.elements["filesize"].value = filesize;'
      '    filesize = filesize.toString();'
      '    filesize = filesize.replace(/(\\d)(?=(\\d\\d\\d)+(?!\\d))/g,"\$1,");'
      '    document.getElementById("filesize").innerHTML = filesize + " bytes";'
      '  }'
      '</script>'
    ));
    pq(qq(
      '<form name="upload"'
      '      action="/fup"'
      '      onsubmit="return showstatus()"'
      '      $formpara>'
      '  <input type="hidden" name="uid"      value="$uid">'
      '  <input type="hidden" name="filesize" value="">'
    ));

    if ($ukey) {
      pq(qq(
        '  <input type="hidden" name="user" value="$from">'
      ));
    } else {
      pq(qq(
        '  <input type="hidden" name="from" value="$from">'
      ));
    }

    if ($public) {
      my $toh = join('<br>',@to);
      pq(qq(
        '  <input type="hidden" name="sender" value="$from">'
        '  <input type="hidden" name="id"     value="$public">'
        '  <input type="hidden" name="to"     value="$to">'
        '  <table border="1">'
        '    <tr><td>sender:   <td>$from</tr>'
        '    <tr><td>recipient:<td>$toh</tr>'
      ));
    } elsif ($okey) {
      pq(qq(
        '  <input type="hidden" name="okey" value="$okey">'
        '  <input type="hidden" name="to"   value="$to">'
        '  <table border="1">'
        '    <tr><td>sender:   <td>$from</tr>'
        '    <tr><td>recipient:<td>$to</tr>'
      ));
    } elsif ($skey) {
      pq(qq(
        '  <input type="hidden" name="skey" value="$skey">'
        '  <table border="1">'
        '    <tr><td>sender:   <td>$from</tr>'
        '    <tr><td>recipient:<td>$to</tr>'
      ));
    } elsif ($ukey) {
      $from = '' if $from eq $to;
      pq(qq(
        '  <input type="hidden" name="ukey" value="$ukey">'
        '  <table border="1">'
        '    <tr><td>sender:   <td><input type="text" name="from" value="$from" size="80"></tr>'
        '    <tr><td>recipient:<td>$to</tr>'
      ));
    } elsif ($pkey) {
      pq(qq(
        '  <input type="hidden" name="pkey" value="$pkey">'
        '  <input type="hidden" name="to"   value="$to">'
        '  <table border="1">'
        '    <tr><td>sender:   <td>$from</tr>'
        '    <tr><td>recipient:<td>$to</tr>'
      ));
    } elsif (@group) {
      if ($gkey) {
        pq(qq(
          '  <input type="hidden" name="gkey" value="$gkey">'
          '  <input type="hidden" name="to"   value="_">'
        ));
      }
      my $toh = "group $group:<ul>";
      foreach my $gm (@group) { $toh .= "<li>$gm" }
      $toh .= "</ul>";
      pq(qq(
        '  <input type="hidden" name="id" value="$id">'
        '  <table border="1">'
        '    <tr><td>sender:<td>$from</tr>'
        '    <tr><td>recipient(s):<td>$toh</tr>'
      ));
    } else {
      my $toc = join(',',@to);
      my $toh = join('<br>',@to);
      pq(qq(
        '  <input type="hidden" name="akey" value="$akey">'
        '  <table border="1">'
        '    <tr><td>sender:<td><a href="/foc">$from</a></tr>'
      ));
      if ($anonymous) {
        pq(qq(
          '    <tr><td>recipient:'
          '        <td><input type="hidden" name="to" value="$toc">$toh</tr>'
        ));
      } else {
        pq(qq(
          '    <tr><td><a href="/fup?to=$toc">recipient(s)</a>:'
          '        <td><input type="hidden" name="to" value="$toc">$toh</tr>'
        ));
      }
    }

    $autodelete = lc $autodelete;
    $keep = $keep_default unless $keep;
    my ($quota,$du) = check_sender_quota($muser||$from);
    $quota = $quota
           ? "<tr><td>sender quota (used):<td>$quota ($du) MB</tr>"
           : '';

    $bwl = qq'<input type="text" name="bwlimit" size="8" value="$bwlimit"> kB/s';
    if (@throttle) {
      foreach (@throttle) {
        if (/\[?(.+?)\]?:(\d+)$/) {
          my $throttle = $1;
          my $limit = $2;
          # throttle ip address?
          if ($throttle =~ /^[\w:.-]+$/) {
            if (ipin($RA,$throttle)) {
              $bwl = qq'<input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
              last;
            }
          }
          # throttle email address?
          else {
            # allow wildcard *, but not regexps
            $throttle =~ quotemeta $throttle;
            $throttle =~ s/\*/.*/g;
            if ($from =~ /^$throttle$/i) {
              $bwl = qq'<input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
              last;
            }
          }
        }
      }
    }

    $autodelete = $autodelete{$to} if $autodelete{$to};

    my $adt = '';
    for ($autodelete) {
         if (/yes/i)   { $adt = 'delete file after download' }
      elsif (/no/i)    { $adt = 'do not delete file after download' }
      elsif (/delay/i) { $adt = 'delete file after download with delay' }
      elsif (/^\d+$/)  { $adt = "delete file $autodelete days after download" }
    }
    $adt .= qq'<input type="hidden" name="autodelete" value="$autodelete">';

    my $ctr;
    if ($nomail) {
      $ctr = qq'<em>no notification email will be send</em>';
    } else {
      $ctr = qq'<input type="text" name="comment" size="80" value="$comment">';
    }
    my $kos;
    if ($share) {
      $kos = qq'<tr><td>share:<td>$share'.
             qq'<input type="hidden" name="share" value="$share"></tr>';
      if ($archive) {
        $kos .= qq'\n    <tr><td>archive set:<td>$archive'.
                qq'<input type="hidden" name="archive" value="$archive"></tr>';
      }
    } else {
      $kos = qq'<tr title="keep file max $keep days, then delete it">'
           . qq'<td>keep:<td>$keep days'
           . qq'<input type="hidden" name="keep" value="$keep"></tr>';
    }
    pq(qq(
      '    <tr><td>autodelete:'
      '      <td>$adt'
      '    </tr>'
      '    $kos'
      '    $quota'
      '    <tr title="optional, full speed if empty"><td>bandwith limit:'
      '      <td>$bwl'
      '    </tr>'
      '    <tr title="optional, will be included in notification email"><td>comment:'
      '      <td>$ctr'
      '    </tr>'
      '    <tr title="If you want to send more than one file, then put them in a zip or tar archive"><td>file:'
      '      <td><input type="file" name="file" size="80" value="$file" onchange="reportsize()">'
      '    </tr>'
      '    <tr><td>file size:<td id="filesize"></td></tr>'
      '  </table>'
      '  <p>'
      '  <input type="submit" value="upload" onclick="checkupload()">'
      '<p>'
      '</form>'
    ));
    if ($share) {
      my $fas = '/fas';
      if ($pkey) {
        $fas .=
          "?owner=$to".
          "?share=$share".
          "?user=$from".
          "?pkey=$pkey".
          "?show=archive:$archive";
      } else {
        $fas .= "?show=archive:$share:$archive";
      }
      pq(qq(
        '<p>'
        '<a href="$back">back to file sharing</a>'
      ));
    }
    if ($akey and -f "$from/@" and not ($captive or $ukey)) {
      pq(qq(
        '<p>'
        '<a href=\"/foc\">user config & operation control</a>'
#        '<form method="post" action="/foc">'
#        '<input type="submit" value="user config & operation control">'
#        '</form>'
      ));
    }
    if ($from eq $admin) {
      pq(qq(
        '<p>'
        '<a href="/fac">server config & admin control</a>'
      ));
    }
    print &logout unless $ukey;
    print $info_2;
    # printf "<hr><pre>%s</pre>\n",$ENV{HTTP_HEADER};
    print "</body></html>\n";
    exit;
  }

  present_locales('/fup');

  my $lost = '';
  if ($ENV{REQUEST_METHOD} eq 'POST') {
    if ($from and -f "$from/@") {
      $lost = '(I have lost my auth-ID! ';
      if ($encryption or -f "$from/@@") {
        $lost .= qq'<a href="/fup?id_forgotten=$from">Send a reset email</a> to $from!\n';
      } else {
        $lost .= qq'<a href="/fup?from=$from&id=?">Mail it</a> to $from!';
      }
      $lost .= ")";
    } else {
      pq(qq(
        '<font color="red">'
        '<h3>You have to fill out this form completely to continue.</h3>'
        '</font>'
      ));
    }
  }

  unless (length($from)) {
    if (($ENV{HTTP_COOKIE}||'') =~ /\blogin=([^\s\/]+@[a-z\d.-]+)/i and -f "$1/@") {
      $from = $1;
    } else {
#      $from = readlink(".login/$RA")||'';
    }
  }

  pq(qq(
    '<form action="/fup" $formpara>'
    '  <table>'
    '    <tr><td>sender:'
    '        <td><input type="text"     name="from" size="40" value="$from"></tr>'
    '    <tr><td>auth-ID:'
    '        <td><input type="password" name="id"   size="16" autocomplete="off"> $lost</tr>'
    '  </table>'
  ));
  if ($ENV{QUERY_STRING} =~ /forward=(\S+)/) {
    print qq'  <input type="hidden" name="forward" value="$1">\n';
  }
  pq(qq(
    '  <p><input type="submit" value="check ID and continue"><p>'
  ));
  if ($mail_authid and not ($fop_auth or $nomail)) {
    unless ($from) {
      pq(qq(
        'If you have lost your auth-ID,'
        'enter your email address in the sender field above and'
        '<input type="submit"><p>'
      ));
    }
  }
  if (not $nomail and (
    @local_domains and @local_hosts or
    @local_rdomains and @local_rhosts or
    @demo
  )) {
    pq(qq(
      'You can <a href="/fur">register yourself</a> '
      'if you do not have a F*EX account yet.<p>'
    ));
  }
  if (@anonymous_upload and ipin($RA,@anonymous_upload)) {
    my $a = 'anonymous_'.int(rand(999999));
    pq(qq(
      'You may also use <a href="/fup?from=anonymous&to=$a">anonymous upload</a>'
    ));
  }
  if (-f "$docdir/sup.html") {
   pq(qq(
     '<br>'
     'You may also use <a href="/sup.html">simple upload</a>'
   ));
  }
  print "</form><p>\n";

  print $info_login||$info_1;

  if ($debug and $debug>1) {
    print "<hr>\n<pre>\n";
    foreach $v (sort keys %ENV) {
      print "$v = $ENV{$v}\n";
    }
    print "</pre>\n";
  }

  print "</body></html>\n";
  exit;
}

# from sup.html
if ($from and $file and not @to) {
  check_rr($from,$from);
  @to = ($from);
  $sup = 'fexyourself';
  $keep{$from} = readlink("$from/\@KEEP")||$keep_default;
}

# all these variables should be defined here, but just to be sure...
http_die("no file specified")	    unless $file;
http_die("no sender specified")     unless $from;
http_die("no recipient specified")  unless @to;
unless ($okey and -l "$to/\@OKEY/$okey" or $pkey) {
  http_die("no auth-ID specified") unless $id;
  unless ($id eq sidhash($rid,$id) or $gkey or $skey or $ukey) {
    faillog("user $from, id $id");
    http_die("wrong auth-ID specified");
  }
}

&check_status($from);

if (@throttle) {
  foreach (@throttle) {
    if (/(.+):(\d+)$/) {
      my $throttle = $1;
      my $limit = $2;
      if (not $bwlimit or $limit < $bwlimit) {
        # throttle ip address?
        if ($throttle =~ /^[\d.-]+$/) {
          if (ipin($RA,$throttle)) {
            $bwlimit = $limit;
            last;
          }
        }
        # throttle email address?
        else {
          # allow wildcard *, but not regexps
          $throttle =~ quotemeta $throttle;
          $throttle =~ s/\*/.*/g;
          if ($from =~ /^$throttle$/i) {
            $bwlimit = $limit;
            last;
          }
        }
      }
    }
  }
}

# address rewriting for storage (swap sender and recipient), see also fop!
if (not ($skey or $gkey) and $from =~ /^(anonymous|fexmail)/) {
  ($from,@to) = ("@to",$from);
}

if (not $anonymous and $overwrite =~ /^n/i) {
  foreach $to (@to) {
    if (-f "$to/$from/$fkey/data") {
      http_die("<code>$file</code> already exists for $to");
    }
  }
}

# additional last check
unless (@group or $gkey or $skey or $public or $okey) {
  foreach $to (@to) {
    checkaddress($to) or
      http_die("$to is not a valid email address");
  }
}


$to = join(',',@to);

# file overwriting for anonymous is only possible if his client has the
# download cookie - else request purging
if ($anonymous and not $seek and my $dkey = readlink("$to/$from/$fkey/dkey")) {
  if ($overwrite =~ /^n/i) {
    http_die("<code>$file</code> already exists for $to");
  }
  if ($ENV{HTTP_COOKIE} !~ /$dkey/) {
    my $purge = "/fop/$dkey/$dkey?purge";
    # http_die("$file already exists $dkey:$ENV{HTTP_COOKIE}:");
    http_die("<code>$file</code> already exists - <a href=\"$purge\">purge it?!</a>");
  }
}

if (@group) {
  @to = @group;
  $comment = "[$group] $comment";
} elsif ($public) {
  $comment .= ' (public upload)';
} elsif ($ukey and $ukey !~ /_$/) {
  $comment = "[ukey=$ukey] $comment";
}

# file data still waits on STDIN ... get it now!
&get_file;

if ($to eq $from and $file eq 'ADDRESS_BOOK') {
  unlink "$from/\@ADDRESS_BOOK";
  rename "$from/$from/ADDRESS_BOOK/upload","$from/\@ADDRESS_BOOK"
    or http_die("cannot save $from/\@ADDRESS_BOOK - $!\n");
  http_header('200 OK');
  print html_header($head);
  print "address book updated\n";
  print "</body></html>\n";
  exit;
}

my $doxua = readlink_("$from/\@DOCUMENT_EXCHANGE");
if ($doxua eq 'yes' or $doxua eq '' and $document_exchange) {
  $doxua = 1;
} else {
  $doxua = 0;
}

# finalize upload
unless ($nostore) {

  if ($shared) {
    my $archived = "$shared/archives/$archive";
    $filed     = "$archived/$avt";
    $save      = "$filed/data";
    $upload    = "$filed/upload";
    $download  = "$filed/download";
    unlink $save,$download;
    # need archiving?
    if ($azip) {
      my $tmp = "$filed/tmp";
      mkdir $tmp;
      unless (rename $upload,"$tmp/$azip") {
        http_die("cannot create $tmp/$azip - $!\n");
      }
      system qw'zip -q -0 -j',"$save.zip","$tmp/$azip";
      if (not rename("$save.zip",$save) or -s $save < -s "$tmp/$azip") {
        http_die("cannot zip upload - $!\n");
      }
      if (open my $filename,'>',"$filed/filename") {
        print {$filename} sprintf("%s_%s",$archive,$avt);
        close $filename;
      }
      rmrf($tmp);
    } else {
      rename($upload,$save) or http_die("cannot move upload to data - $!\n");
    }

    faslog($shared,"$from uploaded file $archive:$avt");

    if ($share eq '_' and $dkey = readlink("$filed/dkey")) {
      # log dkey
      my $msg = sprintf "%s %s %s %s _/%s/%s\n",
                        isodate(time),$dkey,$from,$from,$archive,$avt;
      writelog('dkey.log',$msg);
    }

    # delete old versions from this uploader
    if (my $mv = readlink("$archived/versions")||readlink("$shared/versions")) {
      my @versions;
      foreach my $v (glob("$archived/*_*")) {
        if (readlink_("$v/uploader") eq $from and -f "$v/data") {
          push @versions,untaint($v);
        }
      }
      if (@versions) {
        while (scalar(@versions) > $mv) {
          rmrf(shift @versions);
        }
      }
    }

    # send notification emails
    my $version = $1 if $avt =~ /([\d_]+)/;
    my $file = sprintf "%s_%s",$archive,$avt;
    my ($key,$to,$durl);

    foreach my $user (glob "$shared/users/*") {
      if (readlink_("$user/notification") eq 'yes') {
        $to = basename($user);
        if ($to eq $owner) {
          $key = md5_hex(sprintf("%s:%s",$file,readline1("$owner/@")));
        } else {
          next unless -f "$user/pkey";
          $key = md5_hex(sprintf("%s:%s",$file,readline1("$user/pkey")));
        }
        $durl = sprintf "%s/%s/%s/%s/%s/%s",
                        $::durl,$owner,$share,$to,$key,$file;
        notify(
          share		=> $share,
          to	 	=> $to,
          from		=> $from,
          filename	=> "$archive:$version",
          filed		=> $filed,
          durl		=> $durl,
          comment	=> $comment,
        );
        debuglog("notify $to $filed");
      }
    }

  } else {

    if ($mup) {
      # directory MIME multipart upload postprocessing
      local $_;
      local $/ = "\n";
      my ($file,$size,$tmp,$zip,$x);
      my $to = $group[0]||$to[0];
      $to =~ s/:\w+=.*//; # remove options from address
      $filed  = "$spooldir/$to/$from/$fkey"; # must be abspath!
      $upload = "$filed/upload";
      $tmp = "$filed/tmp";
      $zip = "$upload.zip";
      open $upload,$upload or http_die("cannot open $upload - $!\n");
      http_header('200 OK','Connection: close');
      print html_header($head);
      print $js_scroll;
      $_ = slurp("$filed/header") or http_die("no header file found");
      $file = mupfile($filed,$_); # files go to $tmp/
      print "<h3>extracting:</h3>\n";
      print "<pre>\n";
      print htmlencode($1),"\n" if $file =~ m:/tmp/(.+):;
      while (<$upload>) {
        if (/^--\Q$boundary/) {
          close $file;
          truncate $file,(-s $file)-2;
          $header = '';
          while (<$upload>) {
            last if /^\r?\n/;
            s/\r//;
            $header .= $_;
          }
          $file = mupfile($filed,$header);
          if ($file =~ m:/tmp/(.+):) {
            print $scroll,htmlencode($1),"\n";
          }
        } else {
          print {$file} $_;
        }
      }
      print "</pre>\n";
      close $file;
      close $upload;
      unless (-d $tmp) { die("no files in upload") }

      # DOX directory upload
      if ($doxua and $comment =~ /^DOX:SAVE=./) {

        if ($from eq "@to") {
          if ($comment eq 'DOX:SAVE=/') {
            # toplevel dox
            my $doxd = "$spooldir/$from/DOX";
            mkdirp($doxd);
            chdir $tmp or die("no $tmp ?!");
            foreach (glob "*") {
              my $a = my $b = untaint($_);
              $b =~ s/[^a-z\d\@~^,.+-]/_/gi;
              rename $a,$b;
            }
            foreach (glob "*") {
              next if -l;
              next unless -d;
              my $dir = untaint($_);
              my $doxdd = "$doxd/$dir";
              unless (-d $doxdd) {
                my @d = localtime time;
                my $dt = sprintf(
                  '_%d%02d%02d_%02d%02d%02d',
                  $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]
                );
                mkdirp("$doxdd$dt");
                symlink basename("$doxdd$dt"),$doxdd
                  or die("cannot symlink $doxdd - $!");
              }
              $_ = `rsync -a $dir/. $doxdd/ 2>&1`;
              if ($? != 0) { die($_) }
              doxunweed($doxdd);
            }
            my $dox = 'dox';
            $dox = $1 if (($ENV{HTTP_REFERER}||'') =~ m:/(dox\w*)/:);
            print qq'<a href="/$dox">back to DOX</a>\n';
          } elsif ($comment =~ /^DOX:SAVE=(.+)/) {
            # decode_utf8() does not work because of internal UTF-8 flag!
            my $dir = '/'.decode('utf-8',urldecode($1));
            $dir =~ s://+:/:g;
            while ($dir =~ s:/\.\./:/__/:) {}
            $dir =~ s:^/::;
            my $doxd = "$spooldir/$from/DOX/$dir";
            unless (-d $doxd) { die("no such DOX directory /$dir") }
            chdir $tmp or die("no $tmp ?!");
            my @files = ();
            foreach (glob '*') {
              foreach (find($_)) {
                push @files,"/$_" if -f and not -l;
              }
            }
            doxlog($from,$doxd,@files);
            @files = map { /(.+)/;$_=$1 } glob '*';
            if (my $errors = move(@files,$doxd)) {
              print "<h3>move error</h3>\n";
              print htmlquote($errors);
            }
            if ($dir =~ m:([^/]+):) {
              my $folder = $1;
              update_dox_folder($folder) ;
              doxunweed($folder);
            }
            my $dox = 'dox';
            $dox = $1 if (($ENV{HTTP_REFERER}||'') =~ m:/(dox\w*)/:);
            my $href = urlencode(encode_utf8("/$dox/$from/$dir"));
            print qq'<a href="$href">back to DOX</a>\n';
          }
          print $scroll,"\n";
          print "</body></html>\n";
          chdir $spooldir;
          rmrf($tmp);
          sleep 3; # wait for showupload to finish
          unlink $upload;
          doxdu($from);
          exit;
        }

        # user dox upload (mup)
        if ($comment =~ m:SAVE=([^/]+)/\Q.upload/$from\E(.*):) {
          my $folder = $1;
          my $dir = '/'.urldecode($2);
          $dir =~ s://+:/:g;
          while ($dir =~ s:/\.\./:/__/:) {}
          $dir =~ s:^/+::;
          my $doxd = "$spooldir/$to/DOX/$folder/.upload/$from/$dir";
          if (-d $doxd) {
            chdir $tmp or die("no $tmp ?!");
            my @files = ();
            foreach (glob '*') {
              foreach (find($_)) {
                push @files,".upload/$from/$dir/$_" if -f and not -l;
              }
            }
            doxlog($from,$doxd,@files);
            # rrrx("[\n\r]",$tmp);
            rmrx("^[.#]",$tmp);
            @files = map { /(.+)/;$_=$1 } glob '*';
            if (my $errors = move(@files,$doxd)) {
              print "<h3>move error</h3>\n";
              print htmlquote($errors);
            }
            doxunweed($doxd);
            my $dox = 'dox';
            $dox = $1 if (($ENV{HTTP_REFERER}||'') =~ m:/(dox\w*)/:);
            my $href = urlencode("/$dox/$to/$folder/UPLOAD/$dir");
            $href =~ s:/+:/:g;
            print qq'<a href="$href">back to DOX</a>\n';
            print $scroll,"\n";
            print "</body></html>\n";
            chdir $spooldir;
            rmrf($tmp);
            sleep 3; # wait for showupload to finish
            unlink $upload;
            doxdu($to);
          } else {
            print "<h2>ERROR</h2>\n";
            print "No $doxd\n";
            print "</body></html>\n";
          }
          exit;
        }
      }

      # regular fex (not dox)
      unlink $zip;
      open my $z,"cd '$tmp' && zip -0 -vr '$zip' * 2>&1|"
        or http_die("cannot run zip - $!");
      print "<h3 id=\"zipping\">zipping</h3>\n";
      print "$scroll\n";
      my $zipping = '';
      my $zipping_ = '';
      while (<$z>) {
        if (/ \(out=(\d+)\) /) {
          $size += $1;
          $zipping = sprintf 'zipping %d MB',int($size/$MB);
          next if $zipping eq $zipping_;
          print qq'<script>';
          print qq'document.getElementById("zipping").innerHTML = "$zipping"';
          print qq'</script>\n';
          $zipping_ = $zipping;
        }
      }
      close $z;
      open $upload,'>>',$upload or die "cannot rewrite $upload - $!\n";
      seek $upload,0,0;
      truncate $upload,0;
      open $zip,$zip or die "cannot open $zip - $!\n";
      print {$upload} $x while read($zip,$x,$bs);
      close $upload;
      close $zip;
      unlink $zip;
      rmrf($tmp);
    }

    # DOX toplevel zip upload
    if ($doxua and $comment eq 'DOX:SAVE=/' and $from eq "@to") {
      if ($fkey =~ /(.+)\.zip$/) {
        my $dir = $1;
        $dir =~ s:[^\w\@%~^.,+-]:_:g;
        my $upload = "$spooldir/$from/$from/$fkey/upload";
        my $doxd = "$spooldir/$from/DOX";
        mkdirp($doxd);
        chdir $doxd or http_die("$doxd - $!");
        unlink $dir; # ==> force new version
        mkdirp($dir);
        chdir $dir or http_die("$dir - $!");
        $_ = `unzip -l $upload 2>&1`;
        if (m:/\.\./|\d\d\s+/:) { http_die("bad zip") }
        open my $z,"unzip -o $upload 2>&1|" or http_die("cannot run unzip - $!");
        http_header('200 OK','Connection: close');
        print html_header($head);
        print $js_scroll;
        pq(qq(
          '<h3>extracting $fkey:</h3>'
          '<pre>'
        ));
        while (<$z>) {
          next if /^Archive:/;
          chomp;
          s/^\s*\w+://;
          print $scroll,htmlencode($_),"\n";
        }
        close $z;
        print "</pre>\n";
        # rrrx("[\n\r]","$doxd/$dir");
        my @x = glob "*";
        my $x = untaint("@x");
        # does it contain a single directory with same name as zip file?
        if ($x eq $dir and -d $x) {
          # then use this directory as folder
          rename $x,"../.$dir" or die "cannot rename $dir - $!\n";
          chdir $doxd;
          rmrf($dir);
          rename ".$dir",$dir or die "cannot rename .$dir - $!\n";
        }
        my @d = localtime time;
        my $dt = sprintf(
          '_%d%02d%02d_%02d%02d%02d',
          $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]
        );
        chdir $doxd;
        rename $dir,"$dir$dt" or die("cannot rename $dir to $dir$dt - $!");
        symlink "$dir$dt",$dir or die("cannot symlink $dir - $!");
        doxunweed($dir);
        my $dox = 'dox';
        $dox = $1 if (($ENV{HTTP_REFERER}||'') =~ m:/(dox\w*)/:);
        pq(qq(
          '<a href="/$dox">back to DOX</a>'
          '$scroll'
          '</body></html>'
        ));
        system qw'chmod -R u+rwX .';
        system qw'chmod -R go+rX-w .';
        sleep 3; # wait for showupload to finish
        chdir $spooldir;
        unlink $upload;
      } else {
        http_die("$fkey is not a zip file");
      }
      doxdu($from);
      exit;
    }

    # single file DOX upload
    if ($doxua and $comment =~ /^DOX:SAVE=(.+)/) {
      # decode_utf8() does not work because of internal UTF-8 flag!
      my $dir = '/'.decode('utf-8',urldecode($1));
      $dir =~ s://+:/:g;
      while ($dir =~ s:/\.\./:/__/:) {}
      $dir =~ s:^/+::;
      my $filed = "$spooldir/$to/$from/$fkey";
      my $upload = "$filed/upload";
      my $folder = $dir;
      $folder =~ s:/.*::;

      if ($from eq "@to") {
        my $doxd = "$spooldir/$to/DOX/$dir";
        my $udir = urlencode($dir);
        unless (-d $doxd) { http_die("no such DOX directory /$udir") }
        if ($fkey eq 'dox.zip') {
          chdir $doxd or http_die("$doxd - $!");
          $_ = `unzip -l $upload 2>&1`;
          if (m:/\.\./|\d\d\s+/:) { http_die("bad zip") }
          open my $z,"unzip -o $upload 2>&1|" or
            http_die("cannot run unzip - $!");
          http_header('200 OK','Connection: close');
          print html_header($head);
          print $js_scroll;
          pq(qq(
            '<h3>extracting $fkey in /$dir:</h3>'
            '<pre>'
          ));
          my @files = ();
          my $sdir = $dir;
          $sdir =~ s:^.+?/::;
          while (<$z>) {
            next if /^Archive:/;
            chomp;
            s/^\s*\w+:\s*//;
            push @files,"$sdir/$_";
            print $scroll,htmlencode($_),"\n";
          }
          close $z;
          # rrrx("[\n\r]",'.');
          my $dox = 'dox';
          $dox = $1 if (($ENV{HTTP_REFERER}||'') =~ m:/(dox\w*)/:);
          my $href = urlencode(encode_utf8("/$dox/$to/$dir"));
          pq(qq(
            '</pre>'
            '<a href="$href">back to DOX</a>'
            '$scroll'
            '</body></html>'
          ));
          doxlog($from,$doxd,@files);
          if ($dir =~ m:([^/]+):) {
            my $folder = $1;
            update_dox_folder($folder) ;
            doxunweed($folder);
          }
          system qw'chmod -R u+rwX .';
          system qw'chmod -R go+rX-w .';
          sleep 3; # wait for showupload to finish
          unlink $upload;
          doxdu($from);
          exit;
        } else {
          chdir $filed or http_die("$filed - $!");
          my $filename = untaint(slurp('filename'));
          $filename = decode('utf-8',$filename);
          sleep 3; # wait for showupload to finish
          unlink("$doxd/$filename");
          rename('upload',"$doxd/$filename")
            or http_die("cannot save $filename - $!");
          if ("$doxd/$filename" =~ m:.+?/DOX/.+?/(.+):) {
            doxlog($from,$doxd,$1);
          }
          update_dox_folder($1)  if $dir =~ m:([^/]+):;
          my $dox = 'dox';
          $dox = $1 if (($ENV{HTTP_REFERER}||'') =~ m:/(dox\w*)/:);
          $dir = urlencode(encode('utf-8',$dir));
          nvt_print(
            "HTTP/1.1 302 Found",
            "Location: /$dox/$to/$dir",
            'Content-Length: 0',
            ""
          );
          doxdu($from);
          exit;
        }
      }

      # user dox upload
      if (-d "$to/DOX/$folder/.upload/$from") {
        $dir =~ s:\Q$folder/.upload/$from\E/?::;
        chdir "$to/DOX/$folder/.upload/$from/$dir" or
          http_die("no DOX directory $to/$folder/$dir/UPLOAD");
        my $cwd = untaint(abs_path('.'));
        if ($fkey eq 'dox.zip') {
          $_ = `unzip -l $upload 2>&1`;
          if (m:/\.\./|\d\d\s+/:) { http_die("bad zip") }
          open my $z,"unzip -o $upload 2>&1|" or
            http_die("cannot run unzip - $!");
          http_header('200 OK','Connection: close');
          print html_header($head);
          print $js_scroll;
          my $upload = 'UPLOAD';
          $upload = "$dir/$upload" if length $dir;
          pq(qq(
            '<h3>extracting $fkey in $folder/$upload of $to:</h3>'
            '<pre>'
          ));
          my @files = ();
          while (<$z>) {
            next if /^Archive:/;
            chomp;
            s/^\s*\w+:\s*//;
            push @files,".upload/$from/$dir/$_";
            print $scroll,htmlencode($_),"\n";
          }
          close $z;
          # rrrx("[\n\r]",$cwd);
          rmrx("^[.#]",$cwd);
          doxunweed($cwd);
          my $dox = 'dox';
          $dox = $1 if (($ENV{HTTP_REFERER}||'') =~ m:/(dox\w*)/:);
          my $href = urlencode("/$dox/$to/$folder/$upload");
          pq(qq(
            '</pre>'
            '<a href="$href">back to DOX</a>'
            '$scroll'
            '</body></html>'
          ));
          doxlog($from,$cwd,@files);
          doxdu($to);
          system qw'chmod -R u+rwX .';
          system qw'chmod -R go+rX-w .';
          sleep 3; # wait for showupload to finish
          unlink $upload;
          exit;
        } else {
          my $filename = untaint(slurp("$filed/filename"));
          $filename =~ s/^[.#]/_/;
          $filename =~ s/[\r\n]/ /g;
          sleep 3; # wait for showupload to finish
          rmrf($filename);
          rename($upload,$filename) or http_die("cannot save $filename - $!");
          $ _ = ".upload/$from/$dir/$filename";
          s:/+:/:g;
          doxlog($from,$cwd,$_);
          my $dox = 'dox';
          $dox = $1 if (($ENV{HTTP_REFERER}||'') =~ m:/(dox\w*)/:);
          $dir = urlencode(encode('utf-8',$dir));
          nvt_print(
            "HTTP/1.1 302 Found",
            "Location: /$dox/$to/$folder/UPLOAD/$dir",
            'Content-Length: 0',
            ""
          );
          doxdu($to);
          exit;
        }
      }
    }

    foreach (@group?@group:@to) {
      my $to = $_; local $_;
      $to =~ s/:\w+=.*//; # remove options from address
      $filed     = "$to/$from/$fkey";
      $save      = "$filed/data";
      $dkeylink  = "$filed/dkey";
      $upload    = "$filed/upload";
      $download  = "$filed/download";
      $dkey{$to} = readlink("$filed/dkey");
      my $time   = isodate(time);
      $overwrite{$to}++ if -f $save and not -f $download;
      unlink $save;
      rename $upload,$save
        or http_die("cannot rename $upload to $save - $!\n");

      # generate new dkey if file has been already downloaded to prevent file
      # corruption on download-resume
      if (-s $download and unlink $download and
          my $dkey = untaint(readlink_($dkeylink))
      ) {
        unlink $dkeylink,"$dkeydir/$dkey";
        symlink '/dev/null',"$dkeydir/$dkey";
        $dkey = randstring(8);
        symlink $dkey,$dkeylink;
        symlink "../$filed","$dkeydir/$dkey";
        $dkey{$to} = $dkey;
      }

      # dkey log
      my $msg = sprintf "%s %s %s %s %s\n",
                        $time,$dkey{$to},$from,$to,$fkey;
      writelog('dkey.log',$msg);

      # user log (recipient) for fexget -w / fexsend -~ FUPWATCH
      {
        mkdir "$to/.log";
        my $log = "$to/.log/fup";
        my $size = -s $save;
        my $comment = slurp("$filed/comment")||'';
        chomp $comment;
        if (open $log,'>>',$log) {
          printf {$log} "%s %s %s %s %s %d \"%s\"\n",
                        $time,$from,$fra,$fkey,$dkey{$to},$size,$comment;
          close $log;
        }
      }

      # send notification email
      if (not $nomail and readlink_("$to/\@NOTIFICATION") !~ /^no/i
          and ($comment or not $overwrite{$to}))
      {
        notify_locale($dkey{$to},'new');
        debuglog("notify $filed [$filename] '$comment'");
      }
    }

  }

  $size = -s $save||0;
  $size = sprintf "%s MB",int($size/$MB+0.5);
}

# send HTTP reply
unless ($mup) {
  nvt_print("HTTP/1.1 200 OK");
}

if ($nostore or $mup) {
  # nothing
} elsif ($from eq $to and $file eq 'STDFEX') {
  # xx needs no more response
  exit;
} elsif ($share) {
  if ($dkey) {
    foreach my $durl (@durl) {
      nvt_print("X-Location: $durl/$dkey/${archive}_$avt");
    }
  }
} else {
  if ($xkey and not $restricted) {
    my $x = "$durl//$xkey";
    $x =~ s:/fop::;
    nvt_print("X-Location: $x");
  }
  if ($anonymous) {
    my $dkey = $dkey{$to};
    my $cookie = $dkey;
    $cookie = $1 if $ENV{HTTP_COOKIE} =~ /anonymous=([\w:]+)/;
    $cookie .= ':'.$dkey if $cookie !~ /$dkey/;
    nvt_print("Set-Cookie: anonymous=$cookie");
    $keep{$to} = readlink("$to/\@KEEP")||$keep_default;
  }
  foreach (@group?@group:@to) {
    my $to = $_;
    $to =~ s/:\w+=.*//; # remove options from address
    my $file = "$to/$from/$fkey";
    my $options = sprintf "(autodelete=%s,keep=%s,locale=%s)",
      readlink("$file/autodelete")||$autodelete,
      readlink("$file/keep")||readlink("$to/\@KEEP")||$keep_default,
      readlink("$to/\@LOCALE")||readlink("$file/locale")||$default_locale;
    nvt_print("X-Recipient: $to $options");
    unless ($restricted) {
      foreach my $durl (@durl) {
        if ($durl =~ /^$ENV{PROTO}/i) {
          nvt_print("X-Location: $durl/$dkey{$to}/$fkey");
        }
      }
    }
  }
}

# from fexdox client (owner)
if ($doxua and $comment =~ /^DOX/ and $from eq "@to" and
    $fkey =~ /^fexsync_(.+)_(\w+)\.(tar|tgz)$/)
{
  my $transfer = $1; # DOX folder name
  my $tkey = $2;
  my $tar = $3 eq 'tar' ? 'tar -xf' : 'tar -xzf';
  my $to = $from;
  my $doxd = "$spooldir/$to/DOX";
  my $data = "$spooldir/$to/$from/$fkey/data";
  my @d = localtime time;
  my $tdt = sprintf(
    '%s_%d%02d%02d_%02d%02d%02d',
    $transfer,$d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]
  );
  my $backups = 1;
  my $new = '';
  my $stream = '';
  my $old = '';

  mkdirp($doxd);
  debuglog("cd $doxd");
  chdir $doxd or http_die("no $doxd - $!\n");
  if (-d $transfer and not -l $transfer) {
    my @d = localtime mtime($transfer);
    $old = sprintf(
      '%s_%d%02d%02d_%02d%02d%02d',
      $transfer,$d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]
    );
    rename  $transfer,$old or http_die("cannot rename $transfer to $old - $!\n");
    symlink $old,$transfer or http_die("cannot symlink $old - $!\n");
  }
  $stream = "$transfer!stream"; # from fexdox first stage
  $new = "$transfer!new";
  rmrf($new);
  $old = untaint(readlink_($transfer));
  if (-d $stream and -d $old and mtime($old) > mtime($stream)) {
    rmrf($stream);
  }
  if (-d $transfer) {
    if (-d $stream) {
      rename $stream,$new or http_die("cannot rename $stream to $new - $!\n");
    } else {
      $_ = `cp -al $old $new 2>&1`;
      http_die($_) if $?;
    }
  } else {
    if (-d $stream) {
      rename $stream,$new or http_die("cannot rename $stream to $new - $!\n");
    } else {
      mkdirp($new);
    }
  }

  chdir $new or http_die("no $new - $!\n");
  debuglog("$tar $data");
  system("$tar $data 2>/dev/null");
  unlink($data);
  # rrrx("[\n\r]",'.');
  utime time,time,'.';
  doxunweed('.');
  system qw'chmod -R u+rwX .';
  system qw'chmod -R go+rX-w .';
#  system(ssplit('find . -type d -exec chmod u=rwx,go=rx {} +'));
#  system(ssplit('find . -type f -exec chmod ug+r,o+r-w  {} +'));

  if ($comment =~ /:DELETE$/ and
      open my $sfiles,"$spooldir/$to/CCC/$transfer#$tkey/sfiles")
  {
    my %sfiles = ();
    while (<$sfiles>) {
      $sfiles{hexdecode($2)} = $1 if /^(\d+) (.+)/;
    }
    close $sfiles;
    # delete extraneous files
    foreach (find('.')) {
      m:^\./(.+): or next;
      $_ = $1;
      next if m:^\.(fexdox|upload)/:; # never delete .fexdox and .upload
      if ((-l or -f) and not $sfiles{$_}) {
        debuglog("unlink $_");
        unlink $_;
      }
    }
    # delete empty directories but keep .fexdox and .upload
    if (opendir my $dir,'.') {
      while (defined($_ = readdir($dir))) {
        if (-d and not -l and not /^(\.|\.\.|\.fexdox|\.upload)$/) {
          rmdirr($_);
        }
      }
      closedir $dir;
    }
  }

  chdir $doxd or die;
  if ($comment =~ /:ADD/) {
    if (-d $old) {
      rmrf($old);
      rename $new,$old;
    } else {
      rename $new,$tdt;
      unlink $transfer;
      symlink $tdt,$transfer or http_die("cannot symlink $tdt");
    }
  } else {
    rename $new,$tdt;
    unlink $transfer;
    symlink $tdt,$transfer or http_die("cannot symlink $tdt");
    rmrf("$old!backup") if -d $old;

    if (open my $fdc,"$transfer/.fexdox/config") {
      while (<$fdc>) {
        $backups = $1 if /^backups\s*=\s*(\d+)/;
      }
      close $fdc;
    }

    if (my @v = grep /^\Q$transfer\E_$vp$/,glob "${transfer}_*") {
      while (scalar(@v)-1 > $backups) {
        my $v = untaint(shift @v);
        rmrf($v,"$v!backup");
      }
    }
  }

  my $location =
    sprintf "%s://%s/dox/%s/%s",
    $ENV{PROTO},($ENV{HTTP_HOST}||$ENV{SERVER_NAME}),$to,$transfer;
  $location =~ s^:(80|443)/^/^;

  nvt_print("Location: $location",'');
  doxdu($from);
  shutdown(STDOUT,2);
  exit;
}

# from fexdox client (user)
if ($okey and $comment =~ /^DOX:/ and $fkey =~ /^fexdox_(.+)_\d+\.(tar|tgz)$/) {
  my $folder = $1;
  my $tar = $2 eq 'tar' ? 'tar -xvf' : 'tar -xvzf';
  my $doxd = "$spooldir/$to/DOX/$folder";
  my $doxu = "$doxd/.upload/$from";

  unlink "$to/\@OKEY/$okey";

  if (chdir $doxu) {

    my $data = "$spooldir/$to/$from/$fkey/data";
    my $alist = "$spooldir/$to/$from/$fkey/alist";
    debuglog("$tar $data");
    if (open $tar,"$tar $data 2>&1|") {
      my @files = ();
      while (<$tar>) {
        chomp;
        push @files,".upload/$from/".hexencode($_);
      }
      close $tar;
      doxlog($from,$doxd,@files);
      unlink $data;
    }

    my %exclude = ();
    my $x = "$doxd/.fexdox/private";
    if (open $x,$x) {
      while (<$x>) {
        next if /^#/;
        s/[\r\n]//g;
        s://+:/:;
        s:^/\Q$folder:/:;
        s:/$::;
        $exclude{$_} = shp2prx($_) if length;
      }
      close $x;
      foreach (find('.')) {
        if (m:^\./(.+): and excluded($1)) {
          rmrf($1);
        }
      }
    }
    doxunweed('.');
    system qw'chmod -R u+rwX .';
    system qw'chmod -R go+rX-w .';
    # system(ssplit('find . -type d -exec chmod u=rwx,go=rx {} +'));
    # system(ssplit('find . -type f -exec chmod ug+r,o+r-w  {} +'));
  }

  my $location =
    sprintf "%s://%s/dox/%s/%s/UPLOAD/",
    $ENV{PROTO},($ENV{HTTP_HOST}||$ENV{SERVER_NAME}),$to,$folder;
  $location =~ s^:(80|443)/^/^;

  nvt_print("Location: $location",'');
  doxdu($to);
  shutdown(STDOUT,2);
  exit;
}

if ($http_client =~ /^(fex|schwuppdiwupp)/) {
  unlink "$to/\@OKEY/$okey" if $okey;
  nvt_print('Content-Type: text/html','Connection: close','');
  if (@warning) {
    foreach (@warning) {
      s/<\/?code>/\"/g;
      s/<.*?>//g;
      print "<!-- %W: $_ -->\n";
    }
  }
  sleep(1);
  shutdown(STDOUT,2);
  exit;
}

if ($ukey and $http_client =~ /^curl/) {
  $_ = "$file ($size) received and saved for $to\n";
  # ukey from fexpack ==> show durl
  $_ .= "$durl/$dkey{$to}/$fkey\n" if $ukey =~ /^_/;
  my $length = length;
  nvt_print(
    'Content-Type: text/plain',
    "Content-Length: $length",
    'Connection: close',
    ''
  );
  print;
  shutdown(STDOUT,2);
  exit;
}

# send HTML report
unless ($mup) {
  nvt_print('Content-Type: text/html','Connection: close','');
  print html_header($head);
}

if ($nostore) {
  printf "%s (%s MB) received\n",$file,int($ndata/$MB);
} elsif ($share) {
  pq(qq(
    '<code>$file</code> ($size) received and saved'
    '<p>'
  ));
  if ($pkey) {
    pq(qq'<a href="/fas/$to/$share/$from/$pkey">share index</a>');
  } else {
    pq(qq'<a href="/fas?show=share:$share:archives">share index</a>');
  }
} else {
  if (@warning) {
    foreach (@warning) {
      print "WARNING: $_<p>\n";
      s/<\/?code>/\"/g;
      s/<.*?>//g;
      print "<!-- %W: $_ -->\n";
    }
  }
  if (not $restricted and ($anonymous or $from eq $to)) {
    my $size = $ndata<2*1024 ? sprintf "%s B",$ndata:
               $ndata<2*$MB  ? sprintf "%s kB",int($ndata/1024):
                               sprintf "%s MB",int($ndata/$MB);
    pq(qq(
      '<code>$file</code> ($size) received and saved<p>'
      'Download URL for copy & paste:'
      '<h2>$durl/$dkey{$to}/$fkey</h2>'
      'Link is valid for $keep{$to} days!<p>'
    ));
  } else {
    if ($ndata<2*1024) {
      print "<code>$file</code> ($ndata B) received and saved<p>\n";
      if (not $boring and not $seek) {
        print "Ehh... $ndata <b>BYTES</b>?! You are kidding?<p>\n";
      }
    } elsif ($ndata<2*$MB) {
      $ndata = int($ndata/1024);
      print "<code>$file</code> ($ndata kB) received and saved<p>\n";
      if ($ndata<1024 and not ($boring or $seek)) {
        print "Using F*EX for less than 1 MB: ",
          "ever heard of MIME email? &#9786;<p>\n";
      }
    } else {
      $ndata = int($ndata/$MB);
      print "<code>$file</code> ($ndata MB) received and saved<p>\n";
    }
    if ($ukey and $ukey =~ /^_/) {
      # ukey from fexpack ==> show durl
      pq(qq(
        '$durl/$dkey{$to}/$fkey'
        '<p>'
      ));
    }
    print "<ul>\n";
    foreach $to (@to) {
      print "<li>";
      if ($nomail or $nomail{$to}) {
        if ($restricted) {
          rmrf("$to/$from/$fkey");
          print "<code>$file</code> removed because you are a restricted user ".
            "and recipient $to cannot receive email<p>\n";
        } else {
          pq(qq(
            '$to cannot receive email &rarr;'
            '<font color="red">'
            '<h3>No notification email has been sent to $to!</h3>'
            '</font>'
            'Download URL for copy & paste:'
          ));
          if ($xkey) {
            my $x = "$durl{$to}//$xkey";
            $x =~ s:/fop::;
            print "<h2><code>$x</code></h2>\n";
          } else {
            print "<h2>$durl/$dkey{$to}/$fkey</h2>\n";
            print "Link is valid for $keep{$to} days!<p>\n";
          }
        }
      } elsif ($overwrite{$to} and not $comment) {
        print "(old <code>$file</code> for $to overwritten)<p>\n"
      } else {
        print "$to notified<p>\n"
    }
    }
    print "</ul>\n";
  }
}

if ($okey) {
  unlink "$to/\@OKEY/$okey";
} elsif ($share) {
} elsif (not $anonymous and not $sup) {
  print "<a href=\"/fup?submit=again";
  if    ($public) { print "&from=$from&to=$to&id=$id" }
  elsif ($skey)   { print "&skey=$skey" }
  elsif ($ukey)   { print "&ukey=$ukey&from=$from" }
  elsif ($gkey)   { print "&gkey=$gkey" }
  elsif ($akey)   { print "&to=$to" }
  print "&bwlimit=$bwlimit&autodelete=$autodelete&keep=$keep\">";
  print "send another file</a>\n";
  if ($http_client !~ /fexsend/ and $http_client =~ /Linux/i) {
    print '<p>Hi Linux-user, try ',
          '<a href="/FAQ/user.html#Why_should_I_use_a_special_F_EX_client">',
          "fexsend</a>! &#9786;<p>\n";
  }
  if ($http_client !~ /fexit/ and $http_client =~ /Windows/i) {
    print '<p>Hi Windows-user, try <a href="/fexit.html">fexit</a>! ',
          "&#9786;<p>\n";
  }
  print &logout;
}
print "$scroll\n" if $mup;
print "</body></html>\n";
shutdown(STDOUT,2);
exit;


# parse GET and POST requests
sub parse_request {
  my %to;
  my ($to,$dkey);
  my ($x,$k,$v);
  my $qs = $ENV{QUERY_STRING};
  local $_;

  # forward request (from fas) is handled later
  $qs =~ s/(^|\?)forward=.*//;

  # get JUP parameters from environment (HTTP headers)
  while (($k,$v) = each %ENV) {
    if ($k =~ s/^FEX_//) {
      setparam($k,$v);
    }
  }

  # decode base64 PATH_INFO to QUERY_STRING
  if ($ENV{PATH_INFO} =~ m:^/(\w+=*)$:) {
    if ($qs) {
      $qs = sprintf("%s&%s",decode_b64($1),$qs);
    } else {
      $qs = decode_b64($1);
    }
  }

  # parse HTTP QUERY_STRING (parameter=value pairs)
  if ($qs) {
    $qs =~ s/\?/&/g if $qs !~ /&/ and $qs =~ /\?\w+=/;
    foreach (split '&',$qs) {
      if (s/^(\w+)=(.*)//) {
        my $p = uc($1);
        my $v = $2;
        # decode URL-encoding
        $v =~ s/%([a-f0-9]{2})/chr(hex($1))/gie;
        setparam($p,$v);
        if ($p eq 'AUTODELETE') {
          $specific{'autodelete'} = $autodelete = $v;
        }
        if ($p eq 'KEEP' and $v =~ /^(\d+)$/) {
          $keep = $1;
          $keep = $keep_max if $keep>$keep_max;
          $specific{'keep'} = $keep;
        }
        # if ($p eq 'LOCALE') {
        #   $specific{'locale'} = $locale = $v;
        # }
      }
    }
  }

  # HTTP redirect does not work correctly with opera!
  # ==> locale handling is now done by fexsrv
  if (0 and $locale) {
    nvt_print(
      "HTTP/1.1 302 Found",
      "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup",
      "Set-Cookie: locale=$locale",
      'Expires: 0',
      'Content-Length: 0',
      ''
    );
    # control back to fexsrv for further HTTP handling
    &reexec;
  }

  if ($showstatus) {
    &showstatus;
    exit;
  }

  # check for akey, gkey, skey and pkey (from HTTP GET)
  &check_keys;

  if ($ENV{REQUEST_METHOD} eq 'POST' and $cl) {
    foreach $sig (keys %SIG) {
      if ($sig !~ /^(CHLD|CLD)$/) {
        $SIG{$sig} = \&sigexit;
      }
    }
    $SIG{PIPE} = 'IGNORE' if $ENV{PROTO} eq 'https'; # stunnel workaround
    $SIG{__DIE__} = \&sigdie;
    http_die("invalid Content-Length header \"$cl\"") if $cl !~ /^-?\d+$/;
    debuglog($0);
    debuglog(sprintf("awaiting %d bytes from %s %s",
                     $cl,$ENV{REMOTE_ADDR}||'',$ENV{REMOTE_HOST}||''),"\n");

    &check_space($cl) if $cl > 0;

    $SIG{ALRM} = sub {
      $SIG{__DIE__} = 'DEFAULT';
      fuplog($to||'',$fkey||'-',$RB,'(TIMEOUT)');
      die "TIMEOUT\n";
    };
    alarm($timeout);
    binmode(STDIN,':raw');

    if (defined($ENV{FEX_FILENAME})) {
      # JUP via HTTP header
      $file = $param{'FILE'} = $ENV{FEX_FILENAME};
      $fileid = $ENV{FEX_FILEID} || 0;
      $fpsize = $ENV{X_CONTENT_LENGTH} || 0;
      $boundary = '';
    } elsif ($contentlength) {
      # JUP via URL parameter
      $fpsize = $contentlength;
      $boundary = '';
    } else {
      # FUP
      if (($ENV{CONTENT_TYPE}||'') =~ /boundary=\"?([^\s\";,]+)/) {
        $boundary = $1;
      } else {
        http_die("malformed HTTP POST (no boundary found)");
      }

      READPOST: while (&nvt_read) {
        # the file itself - *must* be last part of POST!
        if (/^Content-Disposition:\s*form-data;\s*name="file";\s*filename="(.+)"/i) {
          push @header,$_;
          $file = $param{'FILE'} = $1;
          while (&nvt_read) {
            last if /^\s*$/;
            $fileid = $1 if /^X-File-ID:\s*(.+)/;
            $fpsize = $1 if /^Content-Length:\s*(\d+)/;
            $flink  = $1 if /^Content-Location:\s*(\/.+)/;
            push @header,$_;
          }
          # STDIN is now at begin of file, will be read later with get_file()
          last;
        }
        if (/^Content-Disposition:\s*form-data;\s*name="directory";\s*filename="(.+)"/i) {
          push @header,$_;
          $file = $param{'FILE'} = $1;
          $file =~ s:/.*::;
          $file .= '.zip';
          $mup = 1;
          while (&nvt_read) {
            last if /^\s*$/;
            push @header,$_;
          }
          # STDIN is now at begin of directory, will be read later with get_file()
          last;
        }
        # all other parameters
        if (/^Content-Disposition:\s*form-data;\s*name="([a-z]\w*)"/i) {
          my $x = $1;
          nvt_skip_to('^\s*$');
          &nvt_read;
          setparam($x,$_);
          NEXTPART: while (&nvt_read) {
            last READPOST if /^--\Q$boundary--/;
            last NEXTPART if /^--\Q$boundary/;
          }
        }
      }
    }

    if (length($file)) {
      $file =~ s/%0D$//; # chomp CR
      $file =~ s/%(\d+)/chr($1)/ge;
      $file = strip_path($file);
      my $ofile = $file;
      # filter out dangerous or invalid chars
      $file = normalize($file);
      $file = '_' unless length($file);
      $file =~ s/[\\\/\|<>:]/_/g;
      $file =~ s/^\./_./;
      # censorship sanctions
      if (%censor) {
        foreach my $rx (keys %censor) {
          $file =~ s/$rx/$censor{$rx}/g;
        }
      }
      if ($file ne $ofile) {
        $ofile =~ s/</&lt;/g;
        $ofile =~ s/>/&gt;/g;
        push @warning,
             "<code>$ofile</code> has been renamed to <code>$file</code>";
      }
      $filename = $file = untaint($file);
      $fkey = urlencode($file);
    }

    # check for akey, gkey, skey and pkey (from HTTP POST)
    &check_keys;

  }

  if ($from) {
    unless ($skey or $gkey or $okey) {
      $from .= '@'.$mdomain if $mdomain and $from !~ /@/;
      if ($from ne 'anonymous' and not checkaddress($from)) {
        http_die("$from is not a valid email address");
      }
    }
    $from = untaint($from);
  }

  # collect multiple addresses and check for aliases (not group)
  if (@to and "@to" !~ /^@[\w-]+$/
      and not ($gkey or $addto or $command =~ /^LIST(RECEIVED)?$/)) {
    # read address book
    if ($from and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
      my ($alias,$addresses,$autodelete,$locale,$keep);
      while (<$AB>) {
        s/#.*//;
        $_ = lc $_;
        if (s/^\s*(\S+)[=\s]+(\S+)//) {
          ($alias,$addresses) = ($1,$2);
          # alias specific options?
          $autodelete = $locale = $keep = '';
          $autodelete = $1 if /autodelete=(\w+)/;
          $locale     = $1 if /locale=(\w+)/;
          $keep       = $1 if /keep=(\d+)/;
          foreach my $address (split(",",$addresses)) {
            # alias address specific :options?
            if ($address =~ s/(.+?):(.+)/$1/) {
              my @options = split(':',$2);
              $address = expand($address);
              foreach (@options) {
                if (/^keep=(\d+)$/i) {
                  $alias_keep{$alias}{$address} = $1
                }
                if (/^autodelete=(yes|no|delay)$/i) {
                  $alias_autodelete{$alias}{$address} = $1
                }
                if (/^locale=(\w+)$/i) {
                  $alias_locale{$alias}{$address} = $1
                }
              }
            } else {
              $address = expand($address);
            }
            push @{$ab{$alias}},$address;
            $autodelete{$alias} = $autodelete if $autodelete;
            $keep{$alias}       = $keep       if $keep;
            $locale{$alias}     = $locale     if $locale;
          }
        }
      }
      close $AB;
    }

    # look for recipient's options and eliminate dupes
    %to = ();
    foreach my $to (my @loop = @to) {
      # address book alias?
      if ($to !~ /@/ and ($ab{$to} or $to =~ /(.+?):(.+)/ and $ab{$1})) {
        my $alias = $to;
        my @options = ();
        $alias =~ s/:(.*)// and @options = split(':',$1);
        if (@options) {
          # alias with :options
          $alias =~ s/:.*//;
          foreach my $address (my @loop = @{$ab{$alias}}) {
            $to{$address} = $address; # ignore dupes
            foreach (@options) {
              $keep{$address} = $1       if /^keep=(\d+)$/i;
              $autodelete{$address} = $1 if /^autodelete=(yes|no|delay)$/i;
              $locale{$address} = $1     if /^locale=(\w+)$/i;
            }
          }
        }
        foreach my $address (my @loop = @{$ab{$alias}}) {
          $to{$address} = $address; # ignore dupes
          unless ($keep{$address}) {
            $keep{$address} = $keep{$alias} if $keep{$alias};
            if ($specific{'keep'}) {
              $keep{$address} = $specific{'keep'}
            } elsif (my $keep = $alias_keep{$alias}{$address}) {
              $keep{$address} = $keep;
            } elsif ($keep{$alias}) {
              $keep{$address} = $keep{$alias}
            }
          }
          unless ($autodelete{$address}) {
            if ($specific{'autodelete'}) {
              $autodelete{$address} = $specific{'autodelete'};
            } elsif (my $autodelete = $alias_autodelete{$alias}{$address}) {
              $autodelete{$address} = $autodelete;
            } elsif ($autodelete{$alias}) {
              $autodelete{$address} = $autodelete{$alias};
            } else {
              $autodelete{$address} = readlink("$address/\@AUTODELETE")
                                      || $autodelete;
            }
          }
          unless ($locale{$address}) {
            if (my $locale = readlink("$address/\@LOCALE")) {
              $locale{$address} = $locale;
            } elsif ($locale{$alias}) {
              $locale{$address} = $locale{$alias};
            } elsif ($locale = $alias_locale{$alias}{$address}) {
              $locale{$address} = $locale;
            } else {
              $locale{$address} = $::locale ;
            }
            $locale{$address} ||= $default_locale || 'english';
          }
        }
      } else {
        # regular address, not an alias
        if ($to =~ s/(.+?):(.+)/$1/) {
          my @options = split(':',$2);
          $to = expand($to);
          foreach (@options) {
            $keep{$to} = $1       if /^keep=(\d+)$/i;
            $autodelete{$to} = $1 if /^autodelete=(yes|no|delay)$/i;
            $locale{$to} = $1     if /^locale=(\w+)$/i;
          }
        }
        $to = expand($to);
        $to{$to} = $to; # ignore dupes
        unless ($autodelete{$to}) {
          $autodelete{$to} = untaint(readlink("$to/\@AUTODELETE")
                                     ||$autodelete);
          if ($specific{'autodelete'}) {
            $autodelete{$to} = $specific{'autodelete'};
          }
        }
        unless ($keep{$to}) {
          $keep{$to} = $keep_default;
          $keep{$to} = $keep                           if $keep;
          $keep{$to} = untaint(readlink("$to/\@KEEP")) if -l "$to/\@KEEP";
          $keep{$to} = $specific{'keep'}               if $specific{'keep'};
        }
        if (my $user_keep_max = readlink("$to/\@KEEP_MAX")) {
          $keep{$to} = $user_keep_max if $keep{$to} > $user_keep_max;
        } else {
          $keep{$to} = $keep_max if $keep_max and $keep{$to} > $keep_max;
        }
      }
      $autodelete{$to} = 'NO' if $to =~ /$amdl/; # mailing lists, etc
      if (-e "$to/\@CAPTIVE") {
        my $v;
        $v = readlink("$to/\@AUTODELETE") and $autodelete{$to} = $v;
        $v = readlink("$to/\@KEEP")       and $keep{$to}       = $v;
      }
    }
    @to = keys %to;

    if (scalar(@to) == 1) {
      $to = "@to";
      $keep       = $keep{$to}       if $keep{$to};
      $autodelete = $autodelete{$to} if $autodelete{$to};
      if ($from eq $to and not $specific{'autodelete'}) {
        $autodelete = $autodelete{$to} = 'NO';
      }
    }

    # check recipients and eliminate dupes
    %to = ();
    foreach $to (@to) {
      if ($to eq 'anonymous') {
        $to{$to} = $to;
      } else {
        if ($to =~ /^@(.+)/) {
          http_die("you cannot send to more than one group") if @to > 1;
          http_die("group $to does not exist") unless -f "$from/\@GROUP/$1";
        } else {
          if ($skey or $gkey or $okey or checkaddress($to)) {
            $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
            $to{$to} = untaint($to);
          } else {
            http_die("$to is not a valid email address");
          }
        }
      }
    }
    @to = values %to;
  }

  foreach $to (@to) {
    unless (checkforbidden($to)) {
      http_die("$to is not allowed");
    }
  }
}


# show the status progress bar
sub showstatus {
  my $wclose;
  my ($upload,$data,$sfile,$ukey,$file);
  my ($nsize,$tsize);
  my ($t0,$t1,$t2,$tt,$ts,$tm);
  my ($osize,$percent,$npercent);
  local $_;

  $wclose = '<p><a href="#" onclick="window.close()">close</a>'."\n".
            '</body></html>'."\n";
  $ukey   = "$ukeydir/$uid";
  $upload = "$ukey/upload";
  $data   = "$ukey/data";
  $sfile  = "$ukey/size";
  for (1..$timeout) {
    sleep 1;
    $tsize = readlink($sfile) and last;
    # upload error?
    # remark: stupid Internet Explorer *needs* the error represented in this
    # asynchronous popup window, because it cannot display the error in the
    # main window on HTTP POST!
    if (-f $ukey and open $ukey,'<',$ukey or
        -f "$ukey/error" and open $ukey,'<',"$ukey/error") {
      undef $/;
      unlink $ukey;
      html_error($error,<$ukey> || 'unknown');
    }
  }
  # unlink $sfile;

  if (defined $tsize and $tsize == 0) {
    print "<script>window.close()</script>\n";
    exit;
  }
  unless ($tsize) {
    html_error($error,
               "no file data received - does your file exist or is it >2GB?")
  }
  html_error($error,"file size unknown") unless $tsize =~ /^\d+$/;

  http_header('200 OK');
  if (open $ukey,'<',"$ukey/filename") {
    local $/;
    $file = <$ukey>;
    close $ukey;
  }
  http_die("no filename?!") unless $file;

  if ((slurp("$ukey/header")||'') =~ /;\s*name="directory";/) {
    $file =~ s:\.zip$:/:;
  }

  my $ssize = $tsize;
  if ($ssize<2097152) {
    $ssize = sprintf "%d kB",int($ssize/1024);
  } else {
    $ssize = sprintf "%d MB",int($ssize/1048576);
  }

  pq(qq(
    "<html><body>"
    "<center>"
    "<h1>Upload Status for<br><code>$file</code> ($ssize)</h1>"
    '<img src="/action-fex-camel.gif" id="afc">'
    "</center>"
    "<input type='text' id='percent' style='margin-left:1ex;color:black;background:transparent;border:none;width:32ex;' disabled='true' value='0%'>"
    "<div style='border:1px solid black;width:100%;height:20px;'>"
    "<div style='float:left;width:0%;background:black;height:20px;' id='bar'>"
    "</div></div>"
  ));

  # wait for upload file
  for (1..9) {
    last if -f $upload or -f $data;
    sleep 1;
  }
  unless (-f $upload or -f $data) {
    print "<p><H3>ERROR: no upload received</H3>\n";
    print $wclose;
    exit;
  }

  $SIG{ALRM} = sub {
    $SIG{__DIE__} = 'DEFAULT';
    pq(qq(
      "<script>"
      "  document.getElementById('afc').src='/logo.jpg'"
      "</script>"
    ));
    die "TIMEOUT in showstatus: no (more) data received\n";
  };
  alarm($timeout*2);

  $t0 = $t1 = time;
  $osize = $percent = 0;

  for ($npercent = 0; $npercent < 100; sleep 1) {
    $t2 = time;
    $nsize = -s $upload;
    if (defined $nsize) {
      if ($nsize<$osize) {
        print "<p><h3>ABORTED</h3>\n";
        print $wclose;
        exit;
      }
      if ($nsize>$osize) {
        alarm($timeout*2);
        $osize = $nsize;
      }
      $npercent = int($nsize*100/$tsize);
      # wait until upload is processed
      # $npercent = 99 if $npercent == 100 and -f $upload;
      $showsize = calcsize($tsize,$nsize);
    } else {
      $npercent = -f $data ? 100 : 99;
      $showsize = calcsize($tsize,$tsize);
    }
    # hint: for ISDN (or even slower) links, 5 s tcp delay is minimum
    # so, updating more often is contra-productive
    if ($t2>$t1+5 or $npercent>$percent) {
      $percent = $npercent;
      $t1 = $t2;
      $tm = int(($t2-$t0)/60);
      $ts = $t2-$t0-$tm*60;
      $tt = sprintf("%d:%02d",$tm,$ts);
      pq(qq(
        "<script>"
        "  document.getElementById('bar').style.width = '$percent%';"
        "  document.getElementById('percent').value = '$showsize, $tt, $percent %';"
        "</script>"
      )) or last;
    }
  }

  alarm(0);
  if ($npercent == 100) {
    print "<h3>file successfully transferred</h3>\n";
  } else {
    print "<h3>file transfer aborted</h3>\n";
  }
  pq(qq(
    "<script>"
    "  document.getElementById('afc').src='/logo.jpg'"
    "</script>"
  ));
  print $wclose;
  unlink $ukey;
  exit;
}


# get file from post request
sub get_file {
  my ($to,$filed,$upload,$nupload,$speed,$download);
  my ($b,$n,$uss);
  my ($dkey,$aprg,$alist);
  my ($fh,$filesize);
  my ($t0,$pt,$tt);
  my @alister;
  my $fb = 0;	# file bytes
  my $ebl = 0;	# end boundary length

  # FUP, not JUP
  if ($boundary) {
    $ebl = length($boundary)+8; # 8: 2 * CRLF + 2 * "--"
  }

  unless ($nostore) {

    unless ($share) {
      # download already in progress?
      foreach $to (@to) {
        $to =~ s/:\w+=.*//; # remove options from address
        $filed = "$to/$from/$fkey";
        $download = "$filed/download";
        if (-f $download and open $download,'>>',$download) {
          flock($download,LOCK_EX|LOCK_NB) or
            http_die("<code>$filed</code> locked: a download is currently in progress");
        }
      }
    }

    # prepare upload
    foreach $to (@to) {
      if ($shared) {
        $filed = "$shared/archives/$archive/$avt";
        unlink "$filed/data" and unlink "$filed/size";
      } else {
        $to =~ s/:\w+=.*//; # remove options from address
        $filed = "$to/$from/$fkey";
      }
      $nupload = "$filed/upload"; # upload for next recipient
      mkdirp($filed);

      # upload already prepared (for first recipient)?
      if ($upload) {
        # link upload for next recipient
        unless ($upload eq $nupload or
                -r $upload and -r $nupload and
                (stat $upload)[1] == (stat $nupload)[1])
        {
          unlink $nupload;
          link $upload,$nupload;
        }
        if ($alist) {
          unlink "$filed/alist";
          link $alist,"$filed/alist";
        }
      }

      # first recipient => create upload
      else {
        $upload = $nupload;
        unlink "$ukeydir/$uid";
        if ($flink) {
          if ($seek) {
            http_die("cannot resume on link upload");
          }
          &nvt_read and $flink = $_;
          if ($flink !~ /^\//) {
            http_die("no file link name ($flink)");
          }
          $flink = abs_path($flink);
          my $fok;
          foreach (@file_link_dirs) {
            my $dir = abs_path($_);
            $fok = $flink if $flink =~ /^\Q$dir\//;
          }
          unless ($fok) {
            http_die("<code>$flink</code> not allowed for linking");
          }
          my @s = stat($flink);
          unless (@s and ($s[2] & S_IROTH) and -r $flink) {
            http_die("cannot read <code>$flink</code>");
          }
          unless (-f $flink and not -l $flink) {
            http_die("<code>$flink</code> is not a regular file");
          }
          # http_die("DEBUG: flink = $flink");
          &nvt_read;
          &nvt_read if /^$/;
          unless (/^--\Q$boundary--/) {
            http_die("found no MIME end boundary in upload ($_)");
          }
          unlink $upload;
          symlink untaint($flink),$upload;
        } else {
          unlink $upload if -l $upload;
          open $upload,'>>',$upload or http_die("cannot write $upload - $!");
          flock($upload,LOCK_EX|LOCK_NB) or
            http_die("<code>$file</code> locked: a transfer is already in progress");
          unless ($seek) {
            seek $upload,0,0;
            truncate $upload,0;
          }
          # already uploaded file data size
          $uss = -s $upload;
          # provide upload ID symlink for showstatus
          symlink "../$filed","$ukeydir/$uid";
          if ($prefetch) {
            unlink "$filed/data";
            symlink 'upload',"$filed/data";
          }

          if ($filed =~ /\.(tar|tgz|tar\.gz|zip|7z)$/
              and $http_client !~ /fexsync/)
          {
            $alist = "$filed/alist";
            if (open $alist,'>',$alist) {
              print {$alist} "archive index not yet created\n";
              close $alist;
            }
          }
        }
      }

      unlink "$filed/autodelete",
             "$filed/error",
             "$filed/restrictions",
             "$filed/locale",
             "$filed/keep",
             "$filed/header",
             "$filed/id",
             "$filed/ip",
             "$filed/speed",
             "$filed/replyto",
             "$filed/uploader",
             "$filed/useragent",
             "$filed/uurl",
             "$filed/comment",
             "$filed/notify";
      unlink "$filed/size" unless $seek;

      # showstatus needs file name and size
      # fexsend needs full file size (+$seek)
      $fh = "$filed/filename";
      open $fh,'>',$fh or die "cannot write $fh - $!\n";
      print {$fh} $filename;
      close $fh;
      if ($::filesize > 0 or $cl > 0) {
        if ($::filesize > 0) { $filesize = $fpsize || $::filesize }
        else                 { $filesize = $cl-$RB-$ebl+$seek }
        # new file
        unless ($seek) {
          if ($::filesize > 0) {
            # total file size as reported by POST
            mksymlink("$filed/size",$::filesize)
              or die "cannot write $filed/size - $!\n";
          } else {
            # file size as counted
            mksymlink("$filed/size",$filesize)
              or die "cannot write $filed/size - $!\n";
          }
        }
      }

      if ($share) {
        if ($share eq '_') {
          mksymlink("$filed/autodelete",$specific{'autodelete'}||'NO');
        } else {
          mksymlink("$filed/autodelete",'NO');
        }
      } else {
        if ($from eq "@to") {
          # special "fex yourself"
          mksymlink("$filed/autodelete",$specific{'autodelete'}||'NO');
        } else {
          $autodelete{$to} ||= $autodelete;
          if ($autodelete{$to} =~ /^(DELAY|NO|\d+)$/i) {
            mksymlink("$filed/autodelete",$autodelete{$to});
          }
        }

        if (my $keep = $keep{$to} || $::keep) {
          my $keep_max = readlink("$to/\@KEEP")||$::keep_max;
          $keep = $keep_max if $keep>$keep_max;
          mksymlink("$filed/keep",$keep);
        }
      }
      mksymlink("$filed/id",$fileid) if $fileid;
      mksymlink("$filed/ip",$RA)     if $RA;
      if (my $uurl = $ENV{REQUEST_URL}) {
        $uurl =~ s!:443/!/!;
        $uurl =~ s/\?.*//;
        mksymlink("$filed/uurl",$uurl);
      }
      if ($http_client and open $http_client,'>',"$filed/useragent") {
        print {$http_client} $http_client,"\n";
        close $http_client;
      }

      unless ($share) {
        if ($_ = readlink("$to/\@LOCALE")) {
          # mksymlink("$filed/locale",$_);
        } elsif ($locale{$to}) {
          mksymlink("$filed/locale",$locale{$to});
        } elsif ($locale and $locale ne $default_locale) {
          mksymlink("$filed/locale",$locale);
        }
        if ($replyto and $replyto =~ /.@./) {
          mksymlink("$filed/replyto",$replyto);
        }

        my $arh = "$from/\@ALLOWED_RHOSTS";
        if (-s $arh) {
          copy($arh,"$filed/restrictions");
        }

        if (readlink_("$to/\@NOTIFICATION") =~ /^no/i) {
          $nomail{$to} = 'NOTIFICATION';
        }

        if ($nomail) {
          open $fh,'>',"$filed/notify" and close $fh;
        }
      }

      if (@header and open $fh,'>',"$filed/header") {
        print {$fh} join("\n",@header),"\n";
        close $fh;
      }

      if ($comment) {
        if (open $fh,'>',"$filed/comment") {
          print {$fh} encode_utf8($comment),"\n";
          close $fh;
        }
      }

      # provide download ID key
      if ($share and $share eq '_' and $from eq $to or not $share and not
          ($dkey = readlink("$filed/dkey") and -l "$dkeydir/$dkey"))
      {
        $dkey = randstring(8);
        unlink "$dkeydir/$dkey";
        symlink "../$filed","$dkeydir/$dkey"
          or http_die("cannot symlink $dkeydir/$dkey ($!)");
        unlink "$filed/dkey";
        symlink $dkey,"$filed/dkey";
      }

    }

    # extra download (XKEY)?
    if ($anonymous and $fkey =~ /^afex_\d/ or
        $from eq "@to" and $comment =~ s:^//(.*)$:NOMAIL:)
    {
      $xkey = $1||$fkey;
      $nomail = $comment;
      my $x = "$xkeydir/$xkey";
      unless (-l $x and readlink($x) eq "../$from/$from/$fkey") {
        if (-e $x) {
          http_die("extra download key $xkey already exists");
        }
        symlink "../$from/$from/$fkey",$x
          or http_die("cannot symlink $x - $!\n");
        unlink "$x/xkey";
        symlink $xkey,"$x/xkey";
      }
    }

    # save download URL for fexsync
    if ($prefetch and $fkey =~ /^fexsync_(.+)_(\d+)\.(tar|tgz)$/) {
      my $transfer = "$1#$2";
      my $filed = "$from/$from/$fkey";
      if (my $dkey = readlink "$filed/dkey") {
        symlink untaint("$durl/$dkey/$fkey"),"$from/CCC/$transfer/durl";
      }
    }

  }

  # file link?
  if ($flink) {
    # upload link has been already created, no data to read any more
    $to = join(',',@to);
    fuplog($to,$fkey,0);
    debuglog("upload link successfull, dkey=$dkey");
  }

  # regular file
  else {

    # at last, read (real) file data
    $t0 = time();

    # streaming data?
    if ($cl == -1) {
      alarm($timeout*2);
      # read until EOF, including MIME end boundary
      # note: cannot use sysread because of previous buffered read!
      while ($n = read(STDIN,$_,$bs)) {
        $RB += $n;
        $fb += $n;
        syswrite $upload,$_ unless $nostore;
        alarm($timeout*2);
      }
      # size of transferred file, without end boundary
      $ndata = untaint($fb-$ebl);
    }

    # normal file with known file size
    else {

      if ($fpsize) {
        debuglog(sprintf("still awaiting %d+%d = %d bytes",
                 $fpsize,$ebl,$fpsize+$ebl));
        $cl = $RB+$fpsize+$ebl; # recalculate CONTENT_LENGTH
      } else {
        if ($::filesize) {
          $cl = $RB+$::filesize+$ebl; # recalculate CONTENT_LENGTH
        }
        debuglog(sprintf("still awaiting %d-%d = %d bytes",
                         $cl,$RB,$cl-$RB));
      }

      # prefetch means:
      # a client can download while upload is still in progress
      # BUT on NFS a sysread can block when the write-rate is too high!
      # The workaround hack is: close and reopen the upload file
      # See prefetch comment below
      if ($prefetch) {
        close $upload;
        # need an other lock filehandle
        open $prefetch,'>>',$upload;
        flock($prefetch,LOCK_EX|LOCK_NB);
        open $upload,'>>',$upload or http_die("cannot reopen $upload - $!");
        $pt = time;
      }

      # read until end boundary, not EOF
      while ($RB < $cl-$ebl) {
        $b = $cl-$ebl-$RB;
        $b = $bs if $b > $bs;
        # max wait for 1 kB/s, but at least 10 s
        # $timeout = $b/1024;
        # $timeout = 10 if $timeout < 10;
        alarm($timeout);
        # note: cannot use sysread because of previous buffered read!
        if ($n = read(STDIN,$_,$b)) {
          $RB += $n;
          $fb += $n;
          # syswrite is much faster than print
          # print {$upload} $_ unless $nostore;
          syswrite $upload,$_ unless $nostore;
          if ($bwlimit) {
            alarm(0);
            $tt = (time-$t0) || 1;
            while ($RB/$tt/1024 > $bwlimit) {
              sleep 1;
              $tt = time-$t0;
            }
          } elsif ($prefetch and time>$pt) {
            # NFS unblocking hack: close and reopen the upload file
            # see prefetch comment above
            close $upload;
            open $upload,'>>',$upload or http_die("cannot append $upload - $!");
            flock($upload,LOCK_EX|LOCK_NB);
            $pt = time;
          }
          # debuglog($_);
        } else {
          last;
        }
      }
      $RB += $ebl;
      $ndata = untaint($fb);
    }

    alarm(0);

    unless ($nostore) {
      close $upload; # or die "cannot close $upload - $!\n";;

      # throuput in kB/s
      $tt = (time-$t0) || 1;
      mksymlink("$filed/speed",int($fb/1024/$tt));

      unless ($ndata) {
        http_die(
          "No file data received!".
          " File name correct?".
          " File too big (browser-limit: 2 GB!)?"
        );
      }

      $to = join(',',@to);

      # streaming upload?
      if ($cl == -1) {

        open $upload,'<',$upload or http_die("internal error - cannot read upload");
        seek $upload,$ndata+2,0;
        $_ = <$upload>||'';
        unless (/^--\Q$boundary--/) {
          http_die("found no MIME end boundary in upload ($_)");
        }
        close $upload;
        truncate $upload,$ndata;

      } else {

        # truncate boundary string
        # truncate $upload,$ndata+$uss if -s $upload > $ndata+$uss;

        # incomplete?
        if ($cl != $RB) {
          fuplog($to,$fkey,$ndata,'(aborted)');
          if ($fpsize) {
            http_die("read $RB bytes, but Content-Length announces $fpsize bytes");
          } else {
            http_die("read $RB bytes, but CONTENT_LENGTH announces $cl bytes");
          }
        }

        # multipost, not complete
        if ($::filesize > -s $upload) {
          http_header('206 Partial OK');
          exit;
        }

        # save error?
        if (-s $upload > ($::filesize||$filesize)) {
          fuplog($to,$fkey,$ndata,'(write error: upload > filesize)');
          http_die("internal server error while writing file data");
        }

      }
      fuplog(sprintf("%s %s %s/%s",
        $to,$fkey,$ndata,-s "$filed/upload"||-s "$filed/data"||0));
      $dkey ||= '';
      debuglog("upload successfull, dkey=$dkey");

      if ($share and $share ne '_') {
        symlink $from,"$filed/uploader";
      }

      if ($alist) {
        my $tarlist = "$FEXHOME/bin/tarlist";
        if ($filed =~ /\.tar$/) {
          if (-x $tarlist) {
            @alister = ($tarlist);
          } else {
            @alister = qw'tar tvf';
          }
        } elsif ($filed =~ /\.(tgz|tar\.gz)$/) {
          if (-x $tarlist) {
            @alister = ($tarlist);
          } else {
            @alister = qw'tar tvzf';
          }
        } elsif ($filed =~ /\.zip$/) {
          if (-x "$FEXHOME/bin/unzipl") {
            @alister = ("$FEXHOME/bin/unzipl");
          } else {
            @alister = qw'unzip -l';
          }
        } elsif ($filed =~ /\.7z$/) {
          if (-x "$FEXHOME/bin/7zl") {
            @alister = ("$FEXHOME/bin/7zl");
          } else {
            @alister = qw'7z l';
          }
        }

        if (@alister) {
          if (searchpath($alister[0])) {
            my $pid = fork();
            if (defined $pid and $pid == 0) {
              for (1..5) {
                sleep 1; # wait for rename upload -> data
                if (-f "$filed/data") {
                  system "@alister '$filed/data' >$alist 2>&1";
                  unlink $alist unless -s $alist;
                  exit;
                }
              }
              exit;
            }
          } else {
            if (open $alist,'>',$alist) {
              print {$alist} "cannot create archive index: ",
                             "$alister[0] not installed\n";
              close $alist;
            }
          }
        }
      }

    }
  }
}


sub mupfile {
  my $filed = shift;
  local $_ = shift;

  if (/^Content-Disposition:.*?filename=(.+)/m) {
    my $filename = $1;
    $filename =~ s/\r$//;
    $filename =~ s/^"(.+)"$/$1/;
    $filename =~ s:^/+::;
    $filename =~ s:^[.-]:_:;
    my $dir = "$filed/tmp/".dirname($filename);
    while ($dir =~ s:/\.\./:/__/:) {}
    mkdirp($dir);
    my $file = $dir.'/'.filename($filename);
    open $file,'>',$file or die "cannot write $file - $!\n";
    return $file;
  } else {
    die "no filename in upload MIME part\n";
  }
}


# check recipients restriction
sub check_rr {
  my $from = shift;
  my @to = @_;
  my $rr = "$from/\@ALLOWED_RECIPIENTS";
  my ($allowed,$to,$ar,$rd);

  if (-s $rr and open $rr,'<',$rr) {

    $restricted = $rr;

    foreach (@to) {
      my $to = $_;
      $allowed = 0;
      seek $rr,0,0;
      while (<$rr>) {
        chomp;
        s/#.*//;
        s/\s//g;

        if (/^\@LOCAL_RDOMAINS/) {
          $ar = '(@';
          foreach (@local_rdomains) {
            my $rd = $_;
            # allow wildcard *, but not regexps
            $rd =~ s/\./\\./g;
            $rd =~ s/\*/[\\w.-]+/g;
            $ar .= '|[^\@]+\@' . $rd;
          }
          $ar .= ')';
        } elsif (/^\@LOCAL_USERS/ and -s "$to/@") {
          $allowed = 1;
          last;
        } else {
          # allow wildcard *, but not regexps
          $ar = quotemeta $_;
          $ar =~ s/\\\*/[^@]*/g;
        }

        if ($to =~ /^$ar$/i) {
          $allowed = 1;
          last;
        }

      }

      unless ($allowed) {
        fuplog("ERROR: $from not allowed to fex to $to");
        debuglog("$to not in $spooldir/$from/\@ALLOWED_RECIPIENTS");
        http_die("you ($from) are not allowed to fex to $to");
      }
    }

    close $rr;
  }
}


# add domain to user if necessary
sub expand {
  my @users = @_;
  my @ua;

  foreach my $u (my @loop = @users) {
    if ($u =~ /^anonymous(_\d+)?$/) {
      $u = "$u\@$hostname";
    }
    if ($u eq 'nettest') {
      if ($mdomain and -d "$u\@$mdomain") {
        $u .= "\@$mdomain"
      } elsif (-d "$u\@$hostname") {
        $u .= "\@$hostname"
      }
    }
    if    ($u =~ /@/)          { push @ua,$u }
    elsif ($mdomain)           { push @ua,"$u\@$mdomain" }
    elsif (-d "$u\@$hostname") { push @ua,"$u\@$hostname" }
    else                       { push @ua,$u }
  }

  return wantarray ? @ua : join(',',@ua);
}


# forward-copy (bounce) an already uploaded file
sub forward {
  my $file = shift;
  my ($nfile,$to,$AB);
  my ($filename,$keep);
  my (%to);

  http_die("no file data for <code>$file</code>") unless -f "$file/data";

  $keep = $::keep||$keep_default;
  if (my $mt = mtime("$file/data")) { $keep += int((time-$mt)/$DS) }

  if (@to) {

    # check recipients restriction
    check_rr($from,@to);

    # read aliases from address book
    if (open $AB,'<',"$from/\@ADDRESS_BOOK") {
      while (<$AB>) {
        s/#.*//;
        $_ = lc $_;
        if (s/^\s*(\S+)[=\s]+(\S+)//) {
          my ($alias,$address) = ($1,$2);
          foreach my $address (split(",",$address)) {
            $address .= '@'.$mdomain if $mdomain and $address !~ /@/;
            push @{$ab{$alias}},$address;
          }
        }
      }
      close $AB;
    }

    # collect addresses
    foreach my $to (my @loop = @to) {
      if ($ab{$to}) {
        foreach my $address (@{$ab{$to}}) {
          $to{$address} = $address;
        }
      } else {
        $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
        $to{$to} = $to;
      }
    }

    @to = keys %to;

    http_header('200 OK');
    print html_header($head);

    foreach my $to (my @loop = @to) {
      $to =~ s/:\w+=.*//; # remove options from address
      $nfile = $file;
      $nfile =~ s:.*?/:$to/:;
      next if $nfile eq $file;
      mkdirp($nfile);
      http_die("cannot create directory $nfile") unless -d $nfile;
      unlink "$nfile/data",
             "$nfile/upload",
             "$nfile/download",
             "$nfile/alist",
             "$nfile/autodelete",
             "$nfile/error",
             "$nfile/restrictions",
             "$nfile/keep",
             "$nfile/header",
             "$nfile/id",
             "$nfile/speed",
             "$nfile/comment",
             "$nfile/replyto",
             "$nfile/notify";
      if ($comment and open $comment,'>',"$nfile/comment") {
        chomp $comment;
        print {$comment} encode_utf8($comment),"\n";
        close $comment;
      }
      my $autodelete = readlink("$to/\@AUTODELETE") || $::autodelete;
      $autodelete = uc(untaint($autodelete));
      if ($autodelete =~ /^(DELAY|NO|\d+)$/i) {
        symlink $autodelete,"$nfile/autodelete";
      }
      symlink          $keep,           "$nfile/keep";
                  copy("$file/id",      "$nfile/id");
                  copy("$file/ip",      "$nfile/ip");
                  copy("$file/speed",   "$nfile/speed");
                  copy("$file/replyto", "$nfile/replyto");
                  copy("$file/alist",   "$nfile/alist");
      $filename = copy("$file/filename","$nfile/filename");
      link             "$file/data",    "$nfile/data"
        or die http_die("cannot create $nfile/data - $!");
      unless ($dkey = readlink("$nfile/dkey") and -l "$dkeydir/$dkey") {
        $dkey = randstring(8);
        unlink "$dkeydir/$dkey";
        symlink "../$nfile","$dkeydir/$dkey"
          or http_die("cannot symlink $dkeydir/$dkey");
        unlink "$nfile/dkey";
        symlink $dkey,"$nfile/dkey"
          or http_die("cannot create $nfile/dkey - $!");
      }

      if ($nomail or $nomail{$to}) {
        if ($filename) {
          my $url = "$durl/$dkey/".normalize_filename($filename);
          pq(qq(
            'Download-URL for $to:<br>'
            '<code>$url</code>'
            '<p>'
          ));
        }
      } else {
        notify_locale($dkey,'new');
        fuplog($to,urlencode($filename),"(forwarded)");
        if ($filename) {
          pq(qq(
            'File "$filename" copy-forwarded to $to and notified.'
            '<p>'
          ));
        }
      }
    }
    pq(qq(
      '<a href="/foc">back to F*EX operation control</a>'
      '</body></html>'
    ));
  } else {
    $filename = filename($file);
    http_header('200 OK');
    print html_header($head);
    pq(qq(
      '<form name="upload" action="/fup" $formpara>'
      '  <input type="hidden" name="akey"    value="$akey">'
      '  <input type="hidden" name="dkey"    value="$dkey">'
      '  <input type="hidden" name="command" value="FORWARD">'
      '  forward a copy of "<code>$filename</code>" to:<br>'
      '  <input type="text" name="to" size="80">'
      '</form>'
      '</body></html>'
    ));
  }
}


# modify file parameter
sub modify {
  my $file = shift;
  my $filename = filename($file);
  my $dkey = readlink("$file/dkey");
  my $to;
  my @parameter;

  http_die("no file data for <code>$file</code>") unless -f "$file/data";

  $to = $file;
  $to =~ s:/.*::;
  if (my $keep = $specific{'keep'}) {
    my $keep_max = readlink("$to/\@KEEP")||$::keep_max;
    $keep = $keep_max if $keep>$keep_max;
    mksymlink("$file/keep",$keep);
    utime time,time,"$file/filename";
    push @parameter,'KEEP';
  }
  if ($specific{'autodelete'}) {
    mksymlink("$file/autodelete",$autodelete);
    push @parameter,'AUTODELETE';
  }
  if ($comment) {
    if (open $comment,'>',"$file/comment") {
      print {$comment} encode_utf8($comment),"\n";
      close $comment;
    }
    notify_locale($dkey,'new') if $dkey;
    push @parameter,'COMMENT';
  }
  http_header('200 OK');
  print "Parameter ".join(',',@parameter)." modified for $filename for $to\n";
}


sub calcsize {
  my ($tsize,$nsize) = @_;
  if ($tsize<2097152) {
    return sprintf "%d kB",int($nsize/1024);
  } else {
    return sprintf "%d MB",int($nsize/1048576);
  }
}


# set parameter variables
sub setparam {
  my ($v,$vv) = @_;
  my ($idf,$to);

  $v = uc(despace($v));

#  if ($vv =~ /([<>])/) {
#    http_die(sprintf("\"&#%s;\" is not allowed in parameter $v",ord($1)));
#  }

  $param{$v} = $vv;
  if ($v eq 'LOGOUT') {
    my $location = "$ENV{PROTO}://$ENV{HTTP_HOST}/";
    my $login = $FEXHOME.'/cgi-bin/login';
    # skey and gkey are persistant!
    $akey = $1 if $ENV{QUERY_STRING} =~ /AKEY:(\w+)/i;
    unlink "$akeydir/$akey" if $akey;
    if (-x $login) {
      $login = readlink($login) || 'login';
      $location .= basename($login);
    } else {
      $location .= 'fup';
    }
    nvt_print(
      'HTTP/1.1 302 Found',
      "Location: $location",
      'Set-Cookie: akey=; path=/', # ; expires=Thu, 01 Jan 1970 00:00:00 GMT
      'Content-Length: 0',
      ''
    );
    &reexec;
  } elsif ($v eq 'LOCALE' and $vv =~ /^(\w+)$/) {
    $locale = $1;
  } elsif ($v eq 'REDIRECT' and $vv =~ /^([\w?=]+)$/) {
    $redirect = $1;
  } elsif ($v eq 'SKEY' and $vv =~ /^([\w:]+)/) {
    $skey = $1;
    $restricted = $v;
  } elsif ($v eq 'GKEY' and $vv =~ /^([\w:]+)/) {
    $gkey = $1 unless $nomail;
    $restricted = $v;
  } elsif ($v eq 'UKEY' and $vv =~ /^(\w+)$/) {
    $ukey = $1;
    $restricted = $v;
  } elsif ($v eq 'PKEY' and $vv =~ /^((MD5H:)?(\w+))/) {
    $pkey = $1;
    $restricted = $v;
  } elsif ($v eq 'DKEY' and $vv =~ /^(\w+)/) {
    $dkey = $1;
  } elsif ($v eq 'AKEY' and $vv =~ /^(\w+)/) {
    $akey = $1;
  } elsif (($v eq 'FROM' or $v eq 'USER') and $vv =~ /\w/) {
    $from = normalize_email($vv);
    $from = expand($from);
    $from = checkchars('sender address',$from);
    # maybe FROM=SUBUSER !
    # checkaddress($from) or http_die("FROM $from is no legal email address");
  } elsif ($v eq 'REPLYTO') {
    $replyto = normalize_email($vv);
    checkchars('replyto address',$replyto);
    checkaddress($replyto) or
      http_die("REPLYTO $replyto is no legal email address");
  } elsif ($v eq 'ADDTO') {
    $vv =~ s/\s.*//;
    $addto = normalize_email($vv);
  } elsif ($v eq 'SUBMIT') {
    $submit = decode_utf8(normalize($vv));
  } elsif ($v eq 'FEXYOURSELF') {
    $submit = $vv;
    @to = ($from);
    $specific{'autodelete'} = $autodelete = 'no';
  } elsif ($v eq 'TO') {
    # extract AUTODELETE and KEEP options
    if ($vv =~ s/[\s,]+AUTODELETE=(\w+)//i) {
      $specific{'autodelete'} = $autodelete = uc($1);
    }
    if ($vv =~ s/[\s,]+KEEP=(\d+)//i) {
      $keep = $1;
      my $keep_max = readlink("$to/\@KEEP")||$::keep_max;
      $keep = $keep_max if $keep>$keep_max;
      $specific{'keep'} = $keep;
    }
    # extract SHARE
    $share = $1 if $vv =~ s/:SHARE=(\S+)$//i;
    $to	= normalize(lc($vv));
    $to	=~ s/[\n\s;,]+/,/g;
    if ($from) {
      if ($to eq '.') {
        # fake header to force MIME fop
        push @header,'Content-Type: application/x-mime';
        $nomail = $to = $from;
         unless ($specific{'autodelete'}) {
           $specific{'autodelete'} = $autodelete = 'no';
         }
      }
      if ($to eq '+') {
        $prefetch = $nomail = $to = $from;
      }
      if ($to eq '//') {
        $to = $from;
        unless ($specific{'autodelete'}) {
          $specific{'autodelete'} = $autodelete = 'no';
        }
        $comment = '//';
      }
    }
    checkchars('recipient address',$to);
    push @to,split(',',$to);
  } elsif ($v eq 'ID') {
    $id = $vv;
    $id =~ s/^\s+//;
    $id =~ s/\s+$//;
    # checkchars('auth-ID',$id);
    $id_forgotten = $id if $id eq '?';
  } elsif ($v eq 'SHARE') {
    $share = $vv;
  } elsif ($v eq 'ARCHIVE') {
    $archive = $vv;
    $archive =~ s/^\./_/;
    $archive =~ s/[^\w.+-]/_/g;
  } elsif ($v eq 'TCE') {
    $test = despace($vv);
  } elsif ($v eq 'OKEY' and $vv =~ /^(\w+)$/) {
    $okey = $1;
    $restricted = $v;
  } elsif ($v eq 'FILEID' and $vv =~ /^(\w+)$/) {
    $fileid = $1;
  } elsif ($v eq 'CONTENTLENGTH' and $vv =~ /^(\d+)$/) {
    $contentlength = $1;
  } elsif ($v eq 'FILE' or $v eq 'FILENAME') {
    $file = strip_path(normalize($vv));
  } elsif ($v eq 'UID' and $vv =~ /^(\w+)$/) {
    $uid = $1;
  } elsif ($v eq 'ID_FORGOTTEN' and $vv =~ /@/) {
    $id_forgotten = $from = normalize_email($vv);
  } elsif ($v eq 'SHOWSTATUS' and $vv =~ /^(\w+)$/) {
    $showstatus = $uid = $1;
  } elsif ($v eq 'COMMENT') {
    $comment = normalize($vv);
    if ($comment =~ /%[A-F\d]{2}/) {
      $comment = urldecode($comment);
    }
    $comment = decode_utf8($comment);
    $comment =~ s/^\s*!\.!/!SHORTMAIL!/;
    $comment =~ s/^!#!/!NOMAIL!/;
    $comment =~ s/^!-!/!NOSTORE!/;
    $nomail = $comment      if $comment =~ /!NOMAIL!/ or $comment eq 'NOMAIL';
    $nostore = $nomail = $1 if $comment =~ /!(NOSTORE)!/;
    $bcc .= " $from"        if $comment =~ s/\s*!BCC!?\s*//i;
    # backward compatibility
    foreach my $cmd (qw(
      DELETE LIST CHECKQUOTA CHECKRECIPIENT RECEIVEDLOG SENDLOG FOPLOG FORWARD
    )) { $command = $comment if $comment eq $cmd }
  } elsif ($v eq 'COMMAND') {
    $command = normalize($vv);
  } elsif ($v eq 'BWLIMIT' and $vv =~ /^(\d+)$/) {
    $bwlimit = $1;
  } elsif ($v eq 'SEEK' and $vv =~ /^(\d+)$/) {
    $seek = $1;
  } elsif ($v eq 'FILESIZE' and $vv =~ /^(\d+)$/) {
    $filesize = $1; # complete filesize!
    &check_space($filesize-$seek);
  } elsif ($v eq 'AUTODELETE' and $vv =~ /^(\w+)$/) {
    $specific{'autodelete'} = $autodelete = uc($1);
  } elsif ($v eq 'KEEP' and $vv =~ /^(\d+)$/) {
    $keep = $1;
    $specific{'keep'} = $keep;
  } elsif ($v eq 'TIMEOUT' and $vv =~ /^(\d+)$/) {
     $specific{'timeout'} = $timeout = $1;
  }
}


sub id_forgotten {
  my ($id,$to,$subuser,$gm,$skey,$gkey,$url,$fup,$reply);

  return if $nomail;

  $fup = $durl;
  $fup =~ s:/fop:/fup:;

  # full user
  if ($id = readline1("$from/@")) {
    if ($encryption or -f "$from/@@") {
      http_die("auth-ID reset");
    } else {
      $url = "$fup/".b64("from=$from&id=$id");
      $reply = "Your requested F*EX auth-ID for $fup?from=$from is:\n$id\n";
      $reply .= "\nOr use:\n$url\n" if $http_client !~ /Mac OS/;
      mail_forgotten($from,$reply);
    }
    exit;
  }

  # sub user
  foreach my $skey (glob("$skeydir/*")) {
    if (-f $skey and open $skey,'<',$skey) {
      while (<$skey>) {
        $_ = lc;
        if (/^(\w+)=(.+)/) {
          $subuser = $2 if $1 eq 'from';
          $to	   = $2 if $1 eq 'to';
        }
      }
      close $skey;
    }
    if ($from and $to and $from eq $subuser) {
      $skey =~ s:.*/::;
      mail_forgotten($subuser,qqq(qq(
        'Your requested F*EX login is:'
        ''
        '$fup?skey=$skey?$to'
      )));
      exit;
    }
  }

  # group user
  foreach my $gkey (glob("$gkeydir/*")) {
    if (-f $gkey and open $gkey,'<',$gkey) {
      while (<$gkey>) {
        $_ = lc;
        if (/^(\w+)=(.+)/) {
          $gm = $2 if $1 eq 'from';
          $to = $2 if $1 eq 'to';
        }
      }
      close $gkey;
    }
    if ($gm and $to and $from eq $gm) {
      $gkey =~ s:.*/::;
      mail_forgotten($gm,qqq(qq(
        'Your requested F*EX login is:'
        ''
        '$fup?gkey=$gkey'
      )));
      exit;
    }
  }

  http_die("$from is not a F*EX user on this server");
}


sub mail_forgotten {
  my $user = shift;
  my @msg = @_;
  local *P;

  return if $nomail;

  open P,'|-',$sendmail,$user,$bcc or http_die("cannot start sendmail - $!\n");
  pq(P,qq(
    'From: $admin'
    'To: $user'
    'Subject: F*EX service $hostname'
    'X-Mailer: F*EX'
    ''
  ));
  print P @msg;
  close P or http_die("cannot send mail - $!\n");
  http_header('200 OK');
  print html_header($head);
  pq(qq(
    '<h3>Mail has been sent to you ($from)</h3>'
    '<a href="/fup">Back to F*EX login</a>'
    '</body></html>'
  ));
}


# lookup akey, skey, gkey and ukey
sub check_keys {

  if (@to and "@to" ne '_') {
    http_die("you cannot mix TO and SKEY URL parameters") if $skey;
    http_die("you cannot mix TO and GKEY URL parameters") if $gkey;
  }

  if ($pkey and $share and $from and $to) {
    $shared = "$to/SHARE/$share";
    &check_pkey;
    return;
  }

  if ($ukey) {
    if (my $user = readlink("$ukeydir/$ukey")) {
      if ($id = readline1("$user/@")) {
        $from ||= $user;
        $to = $user;
        @to = ($to);
        $rid = $id;
        $nomail = 'xup' if $ukey =~ /_$/;
        return;
      } else {
        http_die("$user unknown");
      }
    } else {
      if ($http_client =~ /^curl/) {
        nvt_print(
          "HTTP/1.1 404 UKEY $ukey not found",
          'Content-Type: text/plain',
          'Connection: close',
          ''
        );
        print "wrong UKEY $ukey\n";
        exit;
      } else {
        http_die("wrong UKEY $ukey");
      }
    }
  }

  # only one key can be valid
  $akey = $gkey = '' if $skey;
  $akey = $skey = '' if $gkey;

  if ($skey) {
    # encrypted SKEY?
    if ($skey =~ s/^MD5H:(.+)/$1/) {
      # search real SKEY
      foreach my $s (glob "$skeydir/*") {
        $s =~ s:.*/::;
        if ($skey eq md5_hex($s.$sid)) {
          $skey = $s;
          last;
        }
      }
    }
    # own (special) skey?
    if (my $user = readlink("$skeydir/$skey")) {
      $id = readline1("$user/@")||'';
      if (md5_hex($id) eq $skey) {
        $from = $to = $user;
        @to = ($to);
        $rid = $id;
      } else {
        http_die("expired SKEY <code>$skey</code>");
      }
    } elsif (open $skey,'<',"$skeydir/$skey") {
      $akey = $gkey = '';
      while (<$skey>) {
        if (/^(\w+)=(.+)/) {
          $from = $2          if lc($1) eq 'from';
          @to = ($muser = $2) if lc($1) eq 'to';
          $rid = $id = $2     if lc($1) eq 'id';
        }
      }
      close $skey;
    } else {
      # $skey = '';
      http_die("invalid SKEY <code>$skey</code>");
    }
  }

  if ($gkey) {
    # encrypted GKEY?
    if ($gkey =~ s/^MD5H:(.+)/$1/) {
      # search real GKEY
      foreach my $g (glob "$gkeydir/*") {
        $g =~ s:.*/::;
        if ($gkey eq md5_hex($g.$sid)) {
          $gkey = $g;
          last;
        }
      }
    }
    if (open $gkey,'<',"$gkeydir/$gkey") {
      $akey = $skey = '';
      while (<$gkey>) {
        if (/^(\w+)=(.+)/) {
          $from        = $2 if lc($1) eq 'from';
          $to = $muser = $2 if lc($1) eq 'to';
          $rid = $id   = $2 if lc($1) eq 'id';
          # $user      = $2 if lc($1) eq 'user';
        }
      }
      close $gkey;
      @to = ($to);
    } else {
      # $gkey = '';
      http_die("invalid GKEY <code>$gkey</code>");
    }
  }

  if ($akey and not $id and not $pkey) {

    # sid is not set with web browser
    # akey with sid is set with schwuppdiwupp & co
    if ($id = readline1("$akeydir/$akey/@")) {
      if (readlink_("$akeydir/$akey") =~ m:.*/(.+):) {
        $from = $1;
      } else {
        http_die("internal server error: unknown akey $akey");
      }
    } else {
      $akey = $id = '';
    }
  }

}


# check if pkey is valid
sub check_pkey {
  unless (-d $shared) {
    http_die("share $to/$share does not exist");
  }
  if ($to eq $from) {
    $rid = $id = readline1("$from/@") or http_die("unknown user $from");
    if ($pkey =~ /^MD5H:/) {
      unless ($sid) { http_die("no SID") }
      if ($pkey ne 'MD5H:'.md5_hex("$id$sid")) {
        http_die("wrong PKEY");
      }
    } else {
      if ($pkey ne md5_hex($id)) {
        http_die("wrong PKEY");
      }
    }
    # we are owner!
    $fulluser = $from;
    $pkey = '';
  } else {
    my $rpkey = readline1("$shared/users/$from/pkey") or
      http_die("share user $to/$share/$from does not exist");
    if ($pkey =~ /^MD5H:/) {
      unless ($sid) { http_die("no SID") }
      if ($pkey ne 'MD5H:'.md5_hex("$rpkey$sid")) {
        http_die("wrong PKEY");
      }
    } elsif ($pkey ne $rpkey) {
      http_die("wrong PKEY");
    }
  }
}


# check if there is enough space on spool
sub check_space {
  my $req = shift;
  my ($df,$free,$uprq);

  return if $flink;

  if (open $df,"df -k $spooldir|") {
    while (<$df>) {
      if (/^.+?\s+\d+\s+\d+\s+(\d+)/ and $req/1024 > $1) {
        $free = int($1/1024);
        $uprq = int($req/$MB);
        if (not $nomail and open $sendmail,"|$sendmail -t") {
          print {$sendmail} qqq(qq(
            'From: $admin'
            'To: $admin'
            'Subject: F*EX spool out of space'
            ''
            'F*EX spool $spooldir on $ENV{SERVER_NAME} is out of space.'
            ''
            'Current free space: $free MB'
            'Upload request: $uprq MB'
          ));
          close $sendmail;
        }
        debuglog("aborting because not enough free space in spool ($free MB)");
        http_die("not enough free space for this upload");
      }
    }
    close $df;
  }
}


sub update_dox_folder {
  my $folder = shift;
  my @d = localtime time;
  my ($lv,$nv);

  chdir "$spooldir/$from/DOX" or return;
  if ($lv = readlink($folder)) {
    $lv = untaint($lv);
    $nv = sprintf(
      '%s_%d%02d%02d_%02d%02d%02d',
      $folder,$d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]
    );

    if (rename $lv,$nv) {
      unlink $folder;
      symlink $nv,$folder;
    }
  }
  chdir $spooldir;
}


# global substitution as a function like in gawk
sub gsub {
  local $_ = shift;
  my ($p,$r) = @_;
  s/$p/$r/g;
  return $_;
}


# alphabetic sort, but with _ first
sub _sort {
  my @a = asort(@_);
  my @b = ();
  foreach (@a) {
    push @b,$_ if /^_/;
  }
  foreach (@a) {
    push @b,$_ unless /^_/;
  }
  return @b;
}


# remove empty directories recursive
sub rmdirr {
  my $dir = shift;
  local $_;

  if (opendir $dir,$dir) {
    while (defined($_ = readdir($dir))) {
      next if /^\.\.?$/;
      $_ = "$dir/$_";
      rmdirr($_) if -d and not -l;
    }
    closedir $dir;
    rmdir untaint($dir) and debuglog("rmdir $dir");
  }
}


# standard log
sub fuplog {
  my $msg = "@_";
  my $time = isodate(time);

  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  $msg = sprintf "%s [%s_%s] %s (%s) %s\n",
                 $time,$$,$ENV{REQUESTCOUNT},$from,$fra,$msg;
  writelog($log,$msg);
}


sub doxlog {
  my $from = shift;
  my $dir = shift;
  my @files = @_;
  my @d = localtime time;
  my $log;
  local $_;

  $dir =~ s:(.+?/DOX/[^/]+).*:$1:;
  mkdir "$dir/.upload";
  $log = "$dir/.upload/log";
  open $log,'>>',$log or return;
  flock($log,LOCK_EX);
  printf {$log}
    "\nUPLOAD %d-%02d-%02d %02d:%02d:%02d %s %s %s\n",
    $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0],
    $from,$ENV{REMOTE_HOST}||'-',$ENV{REMOTE_ADDR}||'.';
  foreach (@files) {
    s:/+:/:g;
    s:^/::;
#   s:^\Q.upload/::;
    $_ = hexencode($_) if /[^ -~]/;
    print {$log} "$1\n" if /(.+)/;
  }
  close $log;
}


sub sigdie {
  local $_ = shift;
  chomp;
  sigexit('DIE',$_);
}


sub sigexit {
  my ($sig) = @_;
  my $msg;
  my $to = join(',',@to);

  $SIG{__DIE__} = 'DEFAULT';
  foreach (keys %SIG) { $SIG{$_} = 'DEFAULT' }

  $msg = @_ ? "@_" : '???';
  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  $msg = sprintf "%s %s (%s) %s %s caught SIGNAL %s %s\n",
                 isodate(time),
                 $from||'-',
                 $fra||'-',
                 $to||'-',
                 encode_Q($file||'-'),
                 $msg,
                 $RB?"(after $RB bytes)":"";

  writelog($log,$msg);

  if ($sig eq 'DIE') {
    shift;
    die "$msg\n";
  } else {
    die "SIGNAL $msg\n";
  }
}


sub present_locales {
  my $url = shift;
  my @locales = @::locales; # from fex.ph
  my ($locale,$lang);

  if ($url =~ /\?/) {
    $url .= "&";
    $url =~ s/locale=\w+&//g;
  } else {
    $url .= "?";
  }

  if (@locales) {
    map { $_ = "$FEXHOME/locale/$_" } @locales;
  } else {
    @locales = glob "$FEXHOME/locale/*";
  }

  if (@locales > 1) {
    print "<h3>";
    foreach my $locale (my @loop = @locales) {
      if (-x "$locale/cgi-bin/fup") {
        $lang = "$locale/lang.html";
        $locale =~ s:.*/::;
        if (open $lang,'<',$lang and $lang = getline($lang)) {
          close $lang;
        } else {
          $lang = $locale;
        }
        print "<a href=\"${url}locale=$locale\">$lang</a> ";
      }
    }
    print "</h3>\n";
  }
}


sub check_camel {
  my ($logo,$camel);
  local $/;

  if (open $logo,"$docdir/logo.jpg") {
    $camel = md5_hex(<$logo>) eq 'ad8a95bba8dd1a61d70bd38611bc2059';
  }
  if ($camel and open $logo,"$docdir/action-fex-camel.gif") {
    $camel = md5_hex(<$logo>) eq '1f3d7acc70377496f95c5adddaf4ca7b';
  }
  http_die("missing camel") unless $camel;
}
