#!/usr/bin/perl -w

# CLI client for the F*EX service (send, list, delete)
#
# see also: fexget
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Copyright: GNU General Public License

use 5.006;
use strict qw(vars subs);
use Getopt::Std;
use Socket;
use IO::Handle;
use IO::Socket::INET;
use File::Basename;
use Digest::MD5 qw(md5_hex);  # encrypted ID / SID
use Encode;
use Config;
# use Smart::Comments;

our ($SH,$fexhome,$tmpdir,$windoof,$sigpipe);
&initvars;

my ($from,$to,$id);	# HTTP POST variables

my $idf;		# ID file
my $atype;		# archive type
my $fexcgi;		# F*EX CGI URL
my @files;		# files to send
my $transferfile;	# intermediate transport file
my ($server,$port,$sid);
my $features = ''; 
my $useragent = 'fexsend';
  
my $usage = <<EOD;
usage: $0 [options] file recipient(s)
   or: $0 [options] -a archive files... recipient(s)
   or: $0 [options] -A archive files...
   or: $0 [special options]
   or: $0 -R FEX-URL e-mail
options: -v           verbose mode
         -d           delete file on fex server
         -c           compress file
         -m limit     limit throughput to limit kB/s
         -u FEX-URL   use FEX-URL
         -f user:ID   use user and ID
         -C comment   add comment to notification e-mail
         -k max       keep file max days on fex server
         -K           really keep: no auto-delete after download
         -D           delay auto-delete after download (until next cleanup)
         -M           MIME-file (to be displayed in webbrowser on download)
         -a archive   put files in archive (.zip .7z .tar .tgz)
         -A archive   put files in archive and send to yourself
         -R FEX mail  self-register your e-mail address at FEX server
special options: -I   initialize ID file
                 -l   list sent files
examples: $0 visualization.mpg framstag\@rus.uni-stuttgart.de
          $0 -a examples.zip *.jpg webmaster\@flupp.org
EOD

autoflush STDERR;

if ($0 eq 'xx') {
  $usage = "usage: send file(s):          xx file...\n".
           "   or: send stdin:            xx -\n".
           "   or: send pipe:             ... | xx\n".
           "   or: get file(s) or stdin:  xx\n".
           "   or: get file(s) quickly:   xx --\n";
  $idf = "$fexhome/idxx";
  $idf = "" unless -f $idf;
}

# foreach my $v (keys %ENV) { print "$v = $ENV{$v}\n"; }

if ($windoof and not @ARGV and not $ENV{PROMPT}) {
  # restart with cmd.exe to have mouse cut+paste
  exec qw(cmd /k),$0,'-W';
  exit;
}

$from = $id = '';
$atype = '';
$idf = "$fexhome/id" unless $idf;

if ($ENV{FEXID}) {
  ($fexcgi,$from,$id) = split(/\s+/,$ENV{FEXID});
} else {
  if ($windoof and not -f $idf) { &init }
  if (open $idf,$idf) {
    $fexcgi = getline($idf) || die "$0: no FEX-URL in $idf\n";
    $from   = getline($idf) || die "$0: no FROM in $idf\n";
    $id     = getline($idf) || die "$0: no ID in $idf\n";
    close $idf;
    unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
      die "$0: illegal FEX-URL \"$fexcgi\" in $idf\n";
    }
    unless ($from =~ /^[_:=\w\-\.\/\@\%\+]+$/) {
      die "$0: illegal FROM \"$from\" in $idf\n";
    }
  }
}

my @_ARGV = @ARGV;
  
our ($opt_q,$opt_h,$opt_v,$opt_m,$opt_c,$opt_k,$opt_d,$opt_l,$opt_I,$opt_K,
     $opt_D,$opt_u,$opt_f,$opt_a,$opt_A,$opt_C,$opt_R,$opt_M,$opt_L,
     $opt_z,$opt_Z);

$opt_q = 1 if @ARGV and $ARGV[-1] eq '--';
$opt_h = $opt_v = $opt_m = $opt_c = $opt_k = $opt_d = $opt_l = $opt_I = 0;
$opt_K = $opt_D = $opt_R = $opt_M = $opt_L = 0;
${'opt_@'} = 0;
$opt_u = $opt_f = $opt_a = $opt_A = $opt_C;
getopts('hvcdDKlILRWMzZ@m:k:u:f:a:A:C:') or die $usage;
die $usage if $opt_h;

die $usage if $opt_m and $opt_m !~ /^\d+/;

if ($opt_K and $opt_D) {
  die "$0: you cannot use both options -D and -K\n";
}

# $opt_C is COMMENT command in FEX protocol
$opt_C = 'DELETE'	if $opt_d;
$opt_C = 'LIST'		if $opt_l or $opt_L;
$opt_C = 'RECEIVEDLOG'	if $opt_Z;
$opt_C = 'SENDLOG'	if $opt_z;
$opt_D = 'DELAY'	if $opt_D;
$opt_D = 'NO'		if $opt_K;

if ($opt_I and $opt_R) {
  die "$0: you cannot use both options -I and -R\n";
}

if ($opt_I) {
  if ($0 eq 'xx') { &show_id } 
  else            { &init }
  exit;
}

if ($opt_R) {
  &register;
  exit;
}

if ($opt_f) {
  ($from,$id) = split(':',$opt_f);
  die $usage unless $id;
}

$fexcgi = $opt_u if $opt_u;

unless ($fexcgi) {
  die "$0: no FEX URL found, use \"$0 -u URL\" or \"$0 -I\"\n";
}

unless ($from and $id) {
  die "$0: no sender found, use \"$0 -f FROM:ID\" or \"$0 -I\"\n";
}

$server = $fexcgi;

$port = 80;
$port = 443 if $server =~ s{https://}{};
$port = $1  if $server =~ s/:(\d+)//;

$server =~ s{http://}{};
$server =~ s{/.*}{};

unless (-d $fexhome) {
  mkdir $fexhome,0700 or die "$0: cannot create FEXHOME $fexhome - $!\n";
}

unless (-d $tmpdir) {
  mkdir $tmpdir,0700 or die "$0: cannot create tmpdir $tmpdir - $!\n";
}

# xx: special file exchange between own accounts
if ($0 eq 'xx') {
  if (not @ARGV and -t) {
    &get_xx;
    exit;
  }
  ($to,@files) = prepare_xx();
  tcpconnect($server,$port);
  $sid = query_sid($server,$port);
} else {
  tcpconnect($server,$port);
  $sid = query_sid($server,$port);
  if (${'opt_@'}) {
    query_address_book($server,$port,$from);
    exit;
  }
  # regular fexsend
  ($to,@files) = prepare_fexsend();
}

@files = ($transferfile) unless @files;

foreach my $file (@files) {
  my (@r,$r); # server responses
  sleep 1;    # do not overrun server!
  @r = formdatapost(
 	from		=> $from,
        to		=> $to,
        id		=> $sid,
        file		=> $file,
        keep		=> $opt_k,
        comment		=> $opt_C,
        autodelete	=> $opt_D, 
  );

  # open P,'|w3m -T text/html -dump' or die "$0: w3m - $!\n";
  # print P @r;
  die "$0: no response from server\n" unless @r;
  die join("\n",@r) if grep /Software error:/,@r;
  if ($r[0] !~ m:^HTTP/.* 200 :) {
    die "$0: server error: $r[0]\n";
  }
  if ($0 ne 'xx') {
    if (($r) = grep /ERROR:/,@r) {
      $r =~ s/.*?:\s*//;
      $r =~ s/<.*//;
      die "$0: server error: $r\n";
    }
    if (($r) = grep /delete/i,@r) {
      $r =~ s/<.+?>//g;
      print "$r\n";
    }
    # if (($r) = grep /X-Recipient:/,@r) {
    #   $r =~ s/X-//g;
    #   $r =~ s/\r?\n//;
    #   print "$r\n";
    # }
    if ($opt_A and ($r) = grep /^Location:/i,@r) {
      $r =~ /(http:.*)/;
      if ($atype eq 'tar') {
        print "download info:\nwget -O- $1 | tar xvf -\n";
      } elsif ($atype eq 'tgz') {
        print "download info:\nwget -O- $1 | tar xvzf -\n";
      } else {
        print "$r\n";
      }
    }
  }
}

# delete transfer tmp file
if ($transferfile and ($0 eq 'xx' or $opt_a)) {
  unlink $transferfile;
}

exit;


sub init {
  die "$0: $idf does already exist. Edit or delete it.\n" if -e $idf;
  unless (-d $fexhome) {
    mkdir $fexhome,0700 or die "$0: cannot create FEXHOME $fexhome - $!\n";
  }
  print "fexsend initialization";
  print " (ignoring command line arguments)" if @ARGV and $opt_I;
  print "\nFEX-URL: ";
  $fexcgi = <STDIN>;
  $fexcgi =~ s/[\s\n]//g;
  die "you MUST provide a FEX-URL!\n" unless $fexcgi;
  if ($fexcgi =~ /\?/) {
    $from = $1 if $fexcgi =~ /from=(.+?)(&|$)/i;
    $id =   $1 if $fexcgi =~ /id=(.+?)(&|$)/i;
    $fexcgi =~ s/\?.*//;
  }
  unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
    die "\"$fexcgi\" is not a legal FEX-URL!\n";
  }
  $fexcgi =~ s:/fup/*$::;
  unless ($from) {
    print "Your e-mail address as registered at $fexcgi: ";
    $from = <STDIN>;
    $from =~ s/[\s\n]//g;
    die "you MUST provide your e-mail address!\n" unless $from;
  }
  unless ($from =~ /^[_:=\w\-\.\/\@\%\+]+$/) {
    die "\"$from\" is not a legal e-mail address!\n";
  }
  unless ($id) {
    print "Your auth-ID for $from at $fexcgi: ";
    $id = <STDIN>;
    $id =~ s/[\s\n]//g;
    die "you MUST provide your ID!\n" unless $id;
  }
  if (open F,">$idf") {
    print F "$fexcgi\n",
            "$from\n",
            "$id\n";
    close F;
    print "data written to $idf\n";
  } else {
    die "$0: cannot write to $idf - $!\n";
  }
}


sub show_id {
  my ($fexcgi,$from,$id);
  if (open $idf,$idf) {
    $fexcgi = <$idf>;
    $from   = <$idf>;
    $id     = <$idf>;
    close $idf;
    die "$0: too few data in $idf" unless defined $id;
    chomp($fexcgi);
    chomp($from);
    chomp($id);
    print "export FEXID='$fexcgi $from $id'\n";
    print "history -d \$((\$HISTCMD-1));history -d \$((\$HISTCMD-1))\n";
  } else {
    die "$0: cannot read $idf - $!\n";
  }
}


sub register {
  my $fs = shift @ARGV or die $usage;
  my $mail = shift @ARGV or die $usage;
  my $port;
  my @hh;
  my ($server,$user,$id);

  die "$0: $idf does already exist\n" if -e $idf;

  if ($fs =~ /^https/) {
    die "$0: cannot handle https at this time\n";
  }

  $fs =~ s{^http://}{};
  $fs =~ s{/.*}{};
  if ($fs =~ s/:(\d+)//) { $port = $1 }
  else                   { $port = 80 }

  tcpconnect($fs,$port);
  push @hh, "GET /fur?user=$mail&verify=no HTTP/1.1",
            "Host: $fs:$port",
            "User-Agent: $useragent",
            '';
  print $hh[1],"\n" if $opt_v;
  nvtsend(@hh);
  $_ = <$SH>;
  unless (defined $_ and /\w/) {
    die "$0: no response from server\n";
  }
  s/\r?\n//;
  unless (/^HTTP.* 200/) {
    s/HTTP.[\s\d.]+//;
    die "$0: server error: $_\n";
  }

  while (<$SH>) {
    s/\r//;
    print if $opt_v;
    last if /^\s*$/;
  }

  while (<$SH>) {
    s/\r//;
    print if $opt_v;
    if (m{http://(.*)/fup\?from=(.+)&ID=(.+)}) {
      $server = $1;
      $user = $2;
      $id = $3;

      if (open F,">$idf") {
        print F "$server\n",
                "$user\n",
                "$id\n";
        close F;
        print "user data written to $idf\n";
        print "you can now fex!\n";
        exit;
      } else {
        die "$0: cannot write to $idf - $!\n";
      }
    }
  }

  die "$0: no account data received from F*EX server\n";

}


sub prepare_xx {
  my $ft;  # output of file shell command
  my $file = '';
  my @files = ();

  $to = $from;
  $opt_D = 'NO';
  # transfer file
  $transferfile = "$tmpdir/STDFEX";
  $opt_C = 'NOMAIL';
  if (-t) {
#    if ("@ARGV" eq '?') {
#      if (-e $transferfile) {
#        exec "fstat -File -Content -Size $transferfile || ls -l $transferfile";
#      } else {
#        warn "$0: no tmpfile $transferfile\n";
#        warn "$0: use '$0 -' to fetch it from the fex server\n";
#      }
#      exit;
#    }
    if ("@ARGV" eq '-') {
      # store STDIN to transfer file
      shelldo("cat > $transferfile");
      @files = ($transferfile);
    } elsif (@ARGV) {
      print "making tar transfer file $transferfile :\n";
      # single file? then add this without path
      if (scalar @ARGV == 1 and $ARGV[0] =~ m:(.+)/(.+):) {
        my ($dir,$file) = ($1,$2);
        chdir $dir or die "$0: $dir - $!\n";
        shelldo(qw(tar -cvz --dereference -f),$transferfile,$file);
      } else {
        shelldo(qw(tar cvzf),$transferfile,@ARGV);
      }
      if ($? or not -s $transferfile) {
        die "$0: error while making tar transfer file\n";
      }
    }
  } else {
    # write input from pipe to transfer file
    shelldo("cat > $transferfile");
    @files = ($transferfile);
  }
  return ($from,@files);
}


sub prepare_fexsend {
  my @to;
  my $file = '';
  my @files = ();
  my ($data,$aname,$alias);
  local $_;

  # list spool
  if ($opt_l or $opt_L) {
    my @r = formdatapost(
	from	=> $from,
        to	=> $opt_l ? '*' : $from,
        id	=> $sid,
        comment	=> $opt_C, 
    );
    die "$0: no response from fex server $server\n" unless @r;
    $_ = shift @r;
    unless (/^HTTP.* 200/) {
      s:HTTP/[\d\. ]+::;
      die "$0: server response: $_\n";
    }
    # list sent files
    if ($opt_l) {
      foreach (@r) {
        next unless /<pre>/ or $data;
        $data = 1;
        last if m:</pre>:;
        if (/(to .* :)/) {
          print "\n$1\n";
        } elsif (m/(\d+) MB (.+)/) {
          printf "%8d MB %s\n",$1,$2;
        }
      }
    } 
    # list received files
    else {
      foreach (@r) {
        next unless /<pre>/ or $data;
        $data = 1;
        next if m:<pre>:;
        last if m:</pre>:;
        if (/(from .* :)/) {
          print "\n$1\n";
        }
        if (m{(\d+) MB <a href="(http://.*/fop/\w+/).+">(.+)</a>( ".*")?}) {
          printf "%8d MB %s%s%s\n",$1,$2,$3,($4||'');
        } elsif (m{(\d+) MB <a href="(http://.*/fop/\w+/.+)">}) {
          printf "%8d MB %s\n",$1,$2;
        }
      }
    }
    exit;
  }

  # list spool
  if ($opt_z or $opt_Z) {
    my @r = formdatapost(
	from	=> $from,
        to	=> $from,
        id	=> $sid,
        comment	=> $opt_C, 
    );
    die "$0: no response from fex server $server\n" unless @r;
    $_ = shift @r;
    unless (/^HTTP.* 200/) {
      s:HTTP/[\d\. ]+::;
      die "$0: server response: $_\n";
    }
    while (shift @r) {}
    foreach (@r) { print "$_\n" }
    exit;
  }
  
  if ($opt_A) {
    $to = $from;
    $opt_a = $opt_A;
    $opt_C = 'NOMAIL' unless $opt_C;
  } else {
    if ($windoof and not @ARGV) { &inquire }
    $to = pop @ARGV or die $usage;
  }

  foreach $to (split(',',$to)) {
    $alias = '';
    if ($to =~ /@/ or $opt_A) {
      push @to,$to;
    } elsif (open my $ma,$ENV{HOME}.'/.mutt/aliases') {
      while (<$ma>) {
        if (/^alias $to\s/i) {
          chomp;
          s/\s*#.*//;
          s/\(.*?\)//;
          s/\s+$//;
          s/.*\s+//;
          s/[<>]//g;
          $alias = $_;
          if ($alias =~ /,/) {
            warn "$0: ignoring mutt multi-alias $to = $alias\n";
            last;
          }
          if ($alias) {
            last if grep {$alias eq $_} @to;
            warn "$0: found mutt alias $to = $alias\n";
            push @to,$alias;
            last;
          }
        }
      }
      close $ma;
      unless ($alias) {
        # unless ($opt_A) {
        #  warn "$0: $to is not an e-mail address and not an alias\n";
        # }
        push @to,$to;
      }
    } else {
      unless ($opt_A) {
        warn "$0: $to is not an e-mail address\n";
      }
      push @to,$to;
    }
  }

  $to = join(',',@to);
  checkrecipient($from,$to) if $features =~ /CHECKRECIPIENT/;
    
  if (@ARGV > 1 and not $opt_a and not $opt_d) {
    print "archive name to send the files (name.tar, name.tgz or name.zip):\n";
    $opt_a = <STDIN>;
    $opt_a =~ s/^\s+//;
    $opt_a =~ s/\s+$//;
  }

  if ($opt_a) {
    $opt_a =~ s/^=//;
    $opt_a =~ s/[^\w_.+-]/_/g;
    if ($opt_a =~ /(.+)\.(zip|tar|tgz|7z)$/) {
      $aname = $1;
      $atype = $2;
    } else {
      die "$0: archive name must be one of ".
          "$opt_a.tar $opt_a.tgz $opt_a.zip\n";
    }
    # no file argument left?
    unless (@ARGV) {
      # use file name as archive name
      push @ARGV,$aname;
      $opt_a =~ s:/+$::g;
      $opt_a =~ s:.*/::g;
    }
    $opt_a .= ".$atype" if $opt_a !~ /\.$atype$/;
    $transferfile = "$tmpdir/$opt_a";
    print "Making fex archive ($opt_a):\n";
    if ($atype eq 'zip') {
      if ($windoof) {
        # if ($opt_c) { system(qw(7z a -tzip),$transferfile,@ARGV) }
        # else        { system(qw(7z a -tzip -mm=copy),$transferfile,@ARGV) }
        system(qw(7z a -tzip),$transferfile,@ARGV);
      } else {
        # zip archives must be < 2 GB, so split as necessary
        @files = zipsplit($transferfile,@ARGV);
        if (scalar(@files) == 1) {
          $transferfile = $files[0];
          $transferfile =~ s/_1.zip$/.zip/;
          rename $files[0],$transferfile;
          @files = ();
        }
      }
    } elsif ($atype eq 'tgz') {
      if ($windoof) {
        die "$0: archive type tgz not available, use tar, zip or 7z\n";
      } else {
        system(qw(tar cvzf),$transferfile,@ARGV);
      }
    } elsif ($atype eq '7z') {
      # http://www.7-zip.org/
      # if ($opt_c) { system(qw(7z a),$transferfile,@ARGV) }
      # else        { system(qw(7z a -mx=0),$transferfile,@ARGV) }
      system(qw(7z a),$transferfile,@ARGV);
    } elsif ($atype eq 'tar') {
      if ($windoof) {
        system(qw(7z a -ttar),$transferfile,@ARGV);
      } else {
        system(qw(tar cvf),$transferfile,@ARGV);
      }
    } else {
      die "$0: unknown archive format \"$atype\"\n";
    }
    # error in making transfer archive?
    if ($?) {
      unlink $transferfile;
      die "$0: $! - aborting upload\n";
    }
    @files = ($transferfile);
    # maybe timeout, so make new connect
    tcpconnect($server,$port);
    $sid = query_sid($server,$port);
  } else {
    unless (@ARGV) {
      if ($windoof) {
        &inquire;
      } else {
        die $usage;
      }
    }
    foreach $file (@ARGV) {
      unless ($opt_d) {
        unless (-f $file) {
          if (-e $file) {
            die "$0: $file is not a regular file, try option -a\n"
          } else {
            die "$0: $file does not exist\n";
          }
        }
        die "$0: cannot read $file\n" unless -r $file;
        # compression?
        if ($opt_c) {
          my ($if,$of);
          $if = $file;
          $if =~ s/([^_\w\.\-])/\\$1/g;
          $file = $tmpdir . '/' . basename($file) . '.gz';
          $of = $file;
          $of =~ s/([^_\w\.\-])/\\$1/g;
          shelldo("gzip <$if>$of");
          die "$0: cannot gzip $file\n" unless -s $file;
        }
      }
      push @files,$file;
    }
  }

  return ($to,@files);
}


sub get_xx {
  my $ft;
  
  $transferfile = "$tmpdir/STDFEX";
  
  # get transfer file from FEX server
  unless ($SH) {
    tcpconnect($server,$port);
    $sid = query_sid($server,$port);
  }
  open F,">$transferfile" or die "$0: cannot write to $transferfile - $!\n\n";
  close F or die "$0: cannot write to $transferfile - $!\n\n";
  fexget($from,$sid,$transferfile);
  # empty file?
  unless (-s $transferfile) {
    unlink $transferfile;
    exit;
  }
  $ft = `file $transferfile`;
  if ($ft =~ /compressed/) {
    rename $transferfile,"$transferfile.gz";
    shelldo('gunzip',"$transferfile.gz");
  }
  $ft = `file $transferfile`;
  if ($ft =~ /tar archive/) {
    if ($opt_q) {
      $_ = 'y';
    } else {
      print "Files in transfer-container:\n\n";
      shelldo('tar','tvf',$transferfile);
      print "\nExtract these files? ";
      $_ = <STDIN>;
    }
    if (/^y/i) {
      system("tar xvf $transferfile && rm $transferfile");
      die "$0: error while untaring, see $transferfile\n" if -f $transferfile;
    }
  } else {
    exec 'cat',$transferfile;
  }
  exit;
}


sub formdatapost {
  my %pv = @_; # post variables hash
  my ($boundary,$filename,$length,$v,$buf,$file,$fsize,$resume,$seek);
  my (@hh,@r);
  my ($B,$b,$t,$bt);
  my ($t0,$t1,$t2,$tt);
  my $bs = 2**16; # blocksize for reading and sending file
  local $_;

  if (defined($file = $pv{file})) {
    $filename = encode_utf8($file);
    $filename =~ s:.*/::;
    $filename =~ s:[\r\n]+: :g;
    $fsize = -s $file;
    $fsize = 0 if $opt_d;
  } else {
    $file = $filename = '';
    $fsize = 0;
  }

  FORMDATAPOST:
    
  @hh = ();
  $seek = 0;
  $resume = '';

  unless ($SH) {
    tcpconnect($server,$port);
    $pv{id} = $sid = query_sid($server,$port);
  }
  
  # ask server if this file has been already sent (only for files > 640 kB)
  if ($file and (-s $file||0) > $bs*10 
      and not ($opt_d or $opt_l or $opt_L)) {
    $seek = query_file($server,$port,$pv{to},$pv{from},$pv{id},$filename,$fsize);
    if ($fsize == $seek) {
      return "$file has been already transfered\n";
    } elsif ($seek and $seek < $fsize) {
      $resume = " (resuming at byte $seek)";
    } elsif ($fsize <= $seek) {
      $seek = 0;
    }
  }

  $boundary = randstring(48);
  
  $pv{seek} = $seek;

  # send HTTP POST variables
  foreach $v (qw(from to id keep autodelete comment seek)) {
    if ($pv{$v}) {
      my $name = uc($v);
      push @hh,"--$boundary";
      push @hh,"Content-Disposition: form-data; name=\"$name\"";
      push @hh,"";
      push @hh,encode_utf8($pv{$v});
    }
  }

  # at last, POST the file
  if ($file) {
    push @hh,"--$boundary";
    push @hh,"Content-Disposition: form-data; name=\"FILE\"; filename=\"$filename\"";
    unless ($opt_d) {
      if ($opt_M) { push @hh,"Content-Type: application/x-mime" }
      else        { push @hh,"Content-Type: application/octet-stream" }
      push @hh,"Content-Length: " . ((-s $file||0) - $seek); # optional header!
      push @hh,"";
    }
    push @hh,"";
  }

  push @hh,"--$boundary--";

  $length = length(join('',@hh)) + scalar(@hh)*2 + $fsize - $seek;

  # add HTTP header
  unshift @hh, "POST /fup HTTP/1.1",
               "Host: $server:$port",
               "User-Agent: $useragent",
               "Content-Length: $length",
               "Content-Type: multipart/form-data; boundary=$boundary",
               '';

  if ($opt_v) {
    $hh[-2] = '(file content)' if $file and not $opt_d;
    print "$_\n" foreach (@hh);
  }

  $SIG{PIPE} = \&sigpipehandler;
#    foreach $sig (keys %SIG) {
#      eval '$SIG{$sig} = sub { print "\n!!! SIGNAL '.$sig.' !!!\n"; exit; }';
#    }

  if ($file) {
    pop @hh;
    pop @hh;
    nvtsend(@hh) or do {
      warn "$0: server has closed the connection, reconnecting...\n";
      sleep 1;
      goto FORMDATAPOST; # necessary: new $sid ==> new @hh
    };
    unless ($opt_d) {
      $t0 = $t2 = time;
      $tt = $t0-1;
      $t1 = 0;
      open $file,$file or die "$0: cannot read $file - $!\n";
      binmode $file;
      seek $file,$seek,0;
      # my $sending = "sending $file to $to$resume";
      $B = 0;
      autoflush $SH 0;
      while ($b = read $file,$buf,$bs) {
        print {$SH} $buf or &sigpipehandler;
        $B += $b;
        $bt += $b;
        $t2 = time;
        if (-t STDOUT and $t2>$t1) {
          # smaller block size is better on slow links
          $bs = 4096 if $t1 and $bs>4096 and $B/($t2-$t0)<65536;
          if ($fsize>2097152) {
            printf STDERR "%s : %d MB (%d%%) %d kB/s        \r",
                   $opt_a||$file,
                   int(($B+$seek)/1048576),int(($B+$seek)/$fsize*100),
                   int($bt/1024/($t2-$tt));
          } else {
            printf STDERR "%s : %d kB (%d%%) %d kB/s        \r",
                   $opt_a||$file,
                   int(($B+$seek)/1024),int(($B+$seek)/$fsize*100),
                   int($bt/1024/($t2-$tt));
          }
          $t1 = $t2;
          if ($t2-$tt>10) {
            $bt = 0;
            $tt = $t2;
          }
        }
        sleep 1 while ($opt_m and $B/1024/(time-$t0+1) > $opt_m);
      }
      close $file;
      $tt = ($t2-$t0)||1;
      # my $transfered = "transfered $file to $to$resume";
      if ($seek) {
        if ($fsize>2097152) {
          printf STDERR "%s : %d MB in %d s (%d kB/s), total %d MB\n",
                 $opt_a||$file,
                 int($B/1048576),$tt,int($B/1024/$tt),int($fsize/1048576);
        } else {
          printf STDERR "%s : %d kB in %d s (%d kB/s), total %d kB\n",
                 $opt_a||$file,
                 int($B/1024),$tt,int($B/1024/$tt),int($fsize/1024);
        }
      } else {
        if ($fsize>2097152) {
          printf STDERR "%s : %d MB in %d s (%d kB/s)\n",
                 $opt_a||$file,
                 int($B/1048576),$tt,int($B/1024/$tt);
        } else {
          printf STDERR "%s : %d kB in %d s (%d kB/s)\n",
                 $opt_a||$file,
                 int($B/1024),$tt,int($B/1024/$tt);
        }
      }
      print STDERR "waiting for server ok..." if -t STDOUT;
    }
    autoflush $SH 1;
    print {$SH} "\r\n--$boundary--\r\n";
  } else {
    autoflush $SH 1;
    nvtsend(@hh);
  }

  # SuSe: Can't locate object method "BINMODE" via package "IO::Socket::SSL::SSL_HANDLE"
  # binmode $SH,':utf8'; 

  print STDERR "\r                         \r" if $file and -t STDOUT;
  while (<$SH>) {
    s/[\r\n]+//;
    last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i;
    push @r,decode_utf8($_);
    print "\t$_\n" if $opt_v;
  }
  if ($file) {
    close $SH;
    undef $SH;
  }
  return @r;
}


sub randstring {
    my $n = shift;
    my @rc = ('A'..'Z','a'..'z',0..9 );
    my $rn = @rc;
    my $rs;

    for (1..$n) { $rs .= $rc[int(rand($rn))] };
    return $rs;
}


sub zipsplit {
  my $zipbase = shift;
  my @files = @_;
  my @zipfiles = ();
  my $file;
  my ($zsize,$size,$n);

  $zipbase =~ s/\.zip$//;
  map { s/([^_\w\+\-\.])/\\$1/g } @files;

  open my $ff,"find @files -type f|" or die "$0: cannot search for @_ - $!\n";
  @files = ();

  zipfile: for (;;) {
    $n++;
    if ($n eq 10) {
      unlink @zipfiles;
      die "$0: too many zip-archives\n";
    }
    $zsize = 0;
    while ($file = <$ff>) {
      chomp $file;
      next if -l $file or not -f $file;
      $size = -s $file;
      if ($size > 2147480000) {
        unlink @zipfiles;
        die "$0: $file too big for zip\n";
      }
      if ($zsize + $size > 2147000000) {
        push @zipfiles,zip($zipbase.'_'.$n.'.zip',@files);
        @files = ($file);
        next zipfile;
      } else {
        push @files,$file;
        $zsize += $size;
      }
    }
    close $ff;
    last;
  }
  push @zipfiles,zip($zipbase.'_'.$n.'.zip',@files);
  return @zipfiles;
}


sub zip {
  no strict 'refs';
  my $zip = shift;
  my $cmd;
  local $_;

  unlink $zip;
  # if ($opt_c) { $cmd = "zip -@ $zip" }
  # else        { $cmd = "zip -0 -@ $zip" }
  $cmd = "zip -@ $zip";
  print $cmd,"\n" if $opt_v;
  open $cmd,"|$cmd" or die "$0: cannot create $zip - $!\n";
  foreach (@_) { print {$cmd} $_."\n" }
  close $cmd or die "$0: zip failed - $!\n";

  return $zip;
}


sub getline {
  my $file = shift;
  while (<$file>) {
    chomp;
    s/^#.*//;
    s/\s+#.*//;
    s/^\s+//;
    s/\s+$//;
    return $_ if length($_);
  }
  return '';
}


# set up tcp/ip connection
sub tcpconnect {
  my ($server,$port) = @_;
  
  $sid = '';
  
  if ($port == 443) {
    eval "use IO::Socket::SSL";
    $SH = IO::Socket::SSL->new(
      PeerAddr => $server,
      PeerPort => $port,
      Proto    => 'tcp',
    );
  } else {
    $SH = IO::Socket::INET->new(
      PeerAddr => $server,
      PeerPort => $port,
      Proto    => 'tcp',
    );
  }
  
  if ($SH) {
    autoflush $SH 1;
  } else {
    die "$0: cannot connect $server:$port - $@\n";
  }
  
  print "TCPCONNECT to $server:$port\n" if $opt_v;
}


sub query_file {
  my ($server,$port,$to,$from,$id,$filename,$fsize) = @_;
  my $seek = 0;
  my $size = 0;
  my $head;
  local $_;

  $filename =~ s/([^_=:,;<>()+.\w\-])/'%'.uc(unpack("H2",$1))/ge; # urlencode
  $head = "HEAD /fop/$to/$from/$filename??&ID=$id HTTP/1.1";
  print $head,"\n" if $opt_v;
  print {$SH} $head,"\r\n\r\n";
  $_ = <$SH>;
  unless (defined $_ and /\w/) {
    die "$0: no response from server\n";
  }
  print "\t$_" if $opt_v;
  unless (/^HTTP.* 200/) {
    s:HTTP/[\d\. ]+::;
    die "$0: server response: $_" unless /no such file/;
  }
  while (<$SH>) {
    last if /^\r?\n/;
    print "\t$_" if $opt_v;
    if (/^Content-Length:\s+(\d+)/i) { $seek = $1 }
    if (/^X-Size:\s+(\d+)/i)         { $size = $1 }
  }
  print "\n" if $opt_v;

  if ($id !~ /^MD5H:/) {
    close $SH;
    tcpconnect($server,$port);
  }

  return $fsize == $size ? $seek : 0;
}


sub query_address_book {
  my ($server,$port,$from) = @_;
  my $req;
  local $_;

  unless ($SH) {
    tcpconnect($server,$port);
    $sid = query_sid($server,$port);
  }

  $req = "GET /fop/$from/$from/ADDRESS_BOOK?ID=$sid HTTP/1.1";
  print $req,"\n" if $opt_v;
  print {$SH} $req,"\r\n\r\n";
  $_ = <$SH>;
  unless (defined $_ and /\w/) {
    die "$0: no response from server\n";
  }
  print "\t$_" if $opt_v;
  unless (/^HTTP.* 200/) {
    s:HTTP/[\d\. ]+::;
    die "$0: server response: $_" unless /no such file/;
  }
  while (<$SH>) {
    last if /^\r?\n/;
    print "\t$_" if $opt_v;
  }
  print "\n" if $opt_v;
  while (<$SH>) {
    if (/\w/) {
      print;
      print "\n" unless /\n$/;
    }
  }
  exit;
}


sub query_sid {
  my ($server,$port) = @_;
  my ($sid,$req);
  local $_;

  $sid = $id;
  $req = "GET SID HTTP/1.1";
  print "$req\n" if $opt_v;
  print {$SH} "$req\r\n",
             "Host: $server:$port\r\n",
             "User-Agent: $useragent\r\n",
             "\r\n";
  $_ = <$SH>;
  unless (defined $_ and /\w/) {
    print "\n" if $opt_v;
    die "$0: no response from server\n";
  }
  s/\r//;
  if (/^HTTP.* 201 (.+)/) {
    print "\t$_" if $opt_v;
    $sid = 'MD5H:'.md5_hex($id.$1);
    while (<$SH>) {
      s/\r//;
      print "\t$_" if $opt_v;
      $features = $1 if /^X-Features: (.+)/i;
      last if /^\n/;
    }
  } else {
    # no SID support from F*EX-Server (old version?)
    close $SH;
    tcpconnect($server,$port);
  }
  return $sid;
}


sub fexget {
  my ($from,$id,$save) = @_;
  my $bs = 4096;
  my ($url,$B,$b,$t0,$t1,$cl);
  my ($ts,$tso);
  local $_;

  $url = "/fop/$from/$from/STDFEX?ID=$id";

  print "GET $url\n" if $opt_v;
  print {$SH} "GET $url HTTP/1.1\r\n\r\n";
  $_ = <$SH>;
  die "$0: no response from $server\n" unless $_;
  s/\r//;
  print "\t$_" if $opt_v;
  unless (/^HTTP\/[\d\.]+ 200/) {
    s/^HTTP\/[\d\. ]+//;
    die "$0: server error: $_";
  }
  while (<$SH>) {
    s/\r//;
    print "\t$_" if $opt_v;
    $cl = $1 if /^Content-Length:\s(\d+)/;
    last if /^$/;
  }

  die "$0: no Content-Length in server-reply\n" unless $cl;
  
  open F,">$save" or die "$0: cannot write to $save - $!\n";
  binmode F;
  
  $t0 = $t1 = time;
  $tso = '';
  
  while ($b = read($SH,$_,$bs)) {
    $B += $b;
    print F;
    if (time > $t1) {
      $t1 = time;
      $ts = ts($B,$cl);
      if ($ts ne $tso) {
        print STDERR $ts,"\r";
        $tso = $ts;
      }
    }
    sleep 1 while ($opt_m and $B/1024/(time-$t0+1) > $opt_m);
  }
  
  print STDERR ts($B,$cl),"\n";
  close F;
}


sub nvtsend {
  local $SIG{PIPE} = sub { $sigpipe = "@_" };
  
  $sigpipe = '';
  
  die "$0: internal error: no active network handle\n" unless $SH;
  die "$0: remote host has cloed the link\n" unless $SH->connected;
  
  foreach my $line (@_) {
    print {$SH} $line,"\r\n";
    if ($sigpipe) {
      undef $SH;
      return 0;
    }
  }
  
  return 1;
}


# transfer status
sub ts {
  my ($b,$tb) = @_;
  return sprintf("transfered: %d MB (%d%%)",int($b/1048576),int($b/$tb*100));
}
  

sub sigpipehandler {
  local $_ = '';

  $SIG{ALRM} = sub { };
  alarm(1);
  if (fileno $SH) {
    @_ = <$SH>;
    if (@_ and $opt_v) {
      die "\n$0: server error: @_\n";
    }
    if (@_ and $_[0] =~ /^HTTP.* \d+ (.*)/) {
      die "\n$0: server error: $1\n";
    }
  }
  warn "\n$0: got SIGPIPE (F*EX server died?)\n";
  warn "retrying...\n";
  sleep 3;
  exec $0,@_ARGV;
  die $!;
}


sub initvars {
  our ($SH,$fexhome,$tmpdir,$windoof);

  if ($Config{osname} =~ /^mswin/i) {
    $windoof = $Config{osname};
    $ENV{HOME} = $ENV{USERPROFILE};
    $fexhome = $ENV{FEXHOME} || $ENV{HOME}.'\\fex';
    $tmpdir = $ENV{FEXTMP} || $ENV{TMP} || "$fexhome\\tmp";
  } else {
    $0 =~ s:.*/::;
    $fexhome = $ENV{FEXHOME} || $ENV{HOME}.'/.fex';
    $tmpdir = $ENV{FEXTMP} || "$fexhome/tmp";
  }

  $| = 1;
}


sub checkrecipient {
  my ($from,$to) = @_;
  my @r;
  local $_;
  
  @r = formdatapost(
	from	=> $from,
        to	=> $to,
        id	=> $sid,
        comment	=> 'CHECKRECIPIENT',
  );

  $_ = shift @r;
  if (/ 2\d\d /) {
    foreach (@r) {
      last if /^$/;
      print "Recipient: $1\n" if /X-Recipient: (.+)/;
    }
  } else {
    s/HTTP.[\s\d.]+//;
    die "$0: server error: $_\n";
  }
}


# for windows
sub inquire {
  my ($file,$to);
  for (;;) {
    print "file to send: ";
    chomp($file = <STDIN>);
    last if -e $file;
    warn "$file does not exist\n";
  }
  print "recipient (e-mail address): ";
  chomp($to = <STDIN>);
  @ARGV = ($file,$to);
}


sub shelldo {
  if (system(@_) < 0) { die "failed: @_\n" }
}
