bin/fexsend

   1 #!/usr/bin/perl -w
   2
   3 # CLI client for the F*EX service (send, list, delete)
   4 #
   5 # see also: fexget
   6 #
   7 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
   8 #
   9 # Perl Artistic Licence
  10
  11 use 5.006;
  12 use strict qw'vars subs';
  13 use Encode;
  14 use Config;
  15 use Socket;
  16 use IO::Handle;
  17 use IO::Socket::INET;
  18 use Getopt::Std;
  19 use File::Basename;
  20 use Cwd qw'abs_path';
  21 use Fcntl qw':flock :mode';
  22 use Digest::MD5 qw'md5_hex';  # encrypted ID / SID
  23 use Time::HiRes qw'time';
  24 # use Smart::Comments;
  25 use constant k => 2**10;
  26 use constant M => 2**20;
  27
  28 eval 'use Net::INET6Glue::INET_is_INET6';
  29
  30 &update if "@ARGV" eq 'UPDATE';
  31
  32 $| = 1;
  33
  34 our ($SH,$fexhome,$idf,$tmpdir,$windoof,$macos,$useragent,$editor,$nomail);
  35 our ($anonymous,$public);
  36 our ($tpid,$frecipient);
  37 our ($FEXID,$FEXXX,$HOME);
  38 our (%alias);
  39 our $chunksize = 0;
  40 our $version = 20160328;
  41 our $_0 = $0;
  42 our $DEBUG = $ENV{DEBUG};
  43
  44 my %SSL = (SSL_version => 'TLSv1');
  45 my $sigpipe;
  46
  47 if ($Config{osname} =~ /^mswin/i) {
  48   # http://slu.livejournal.com/17395.html
  49   $windoof = $Config{osname};
  50   $HOME = $ENV{USERPROFILE};
  51   $fexhome = $ENV{FEXHOME} || $HOME.'\fex';
  52   $tmpdir = $ENV{FEXTMP} || $ENV{TEMP} || "$fexhome\\tmp";
  53   $idf = "$fexhome\\id";
  54   $editor = $ENV{EDITOR} || 'notepad.exe';
  55   $useragent = sprintf("fexsend-$version (%s %s)",
  56                        $Config{osname},$Config{archname});
  57   $SSL{SSL_verify_mode} = 0;
  58 } elsif ($Config{osname} =~ /^darwin/i or $ENV{MACOS}) {
  59   # http://stackoverflow.com/questions/989349/running-a-command-in-a-new-mac-os-x-terminal-window
  60   $macos = $Config{osname};
  61   $HOME = (getpwuid($<))[7]||$ENV{HOME};
  62   $fexhome = $HOME.'/.fex';
  63   $tmpdir = $ENV{FEXTMP} || $ENV{TMPDIR} || "$fexhome/tmp";
  64   $tmpdir =~ s:/$::;
  65   $idf = "$fexhome/id";
  66   chmod 0600,$idf;
  67   $editor = $ENV{EDITOR} || 'open -W -n -e';
  68   $_ = `sw_vers -productVersion 2>/dev/null`||'';
  69   chomp;
  70   $useragent = "fexsend-$version (MacOS $_)";
  71 } else {
  72   $0 =~ s:.*/::;
  73   $HOME = (getpwuid($<))[7]||$ENV{HOME};
  74   $fexhome = $HOME.'/.fex';
  75   $tmpdir = $ENV{FEXTMP} || "$fexhome/tmp";
  76   $idf = "$fexhome/id";
  77   chmod 0600,$idf;
  78   $editor = $ENV{EDITOR} || 'vi';
  79   $_ = `(lsb_release -d||uname -a)2>/dev/null`||'';
  80   chomp;
  81   s/^Description:\s+//;
  82   $useragent = "fexsend-$version ($_)";
  83 }
  84
  85 if (-f ($_ = '/etc/fex/config.pl')) {
  86   eval { require } or warn $@;
  87 }
  88
  89 my $from = '';
  90 my $to = '';
  91 my $id = '';
  92 my $skey = '';
  93 my $gkey = '';
  94 my $atype = '';         # archive type
  95 my $fexcgi;             # F*EX CGI URL
  96 my @files;              # files to send
  97 my %AB = ();            # server based address book
  98 my ($server,$port,$sid,$https);
  99 my $proxy = '';
 100 my $proxy_prefix = '';
 101 my $features = '';
 102 my $timeout = 30;       # server timeout
 103 my $fexlist = "$tmpdir/fexlist";
 104 my ($usage,$hints);
 105 my $xx = $0 =~ /\bxx$/;
 106
 107 if ($xx) {
 108   $usage = "usage: send file(s):               xx [:slot] file...\n".
 109            "   or: send STDIN:                 xx [:slot] -\n".
 110            "   or: send pipe:                  ... | xx [:slot] \n".
 111            "   or: get file(s) or STDIN:       xx [:slot] \n".
 112            "   or: get file(s) no-questions:   xx [:slot] --\n".
 113            "examples: dmesg | xx\n".
 114            "          xx project\n".
 115            "          xx --\n".
 116            "          xx :conf /etc /boot\n";
 117 } else {
 118   $usage = <<EOD;
 119 usage: $0 [options] file(s) [@] recipient(s)
 120    or: $0 [special options]
 121    or: $0 -l [recipient-regexp]
 122    or: $0 -f \# recipient(s)
 123    or: $0 -x \# [-C -k -D -K -S]
 124 options: -v           verbose mode
 125          -d           delete file on fex server
 126          -c           compress file with gzip
 127          -g           encrypt file with gpg
 128          -m limit     limit throughput (kB/s)
 129          -i account   use ID data [account] from ID file
 130          -C comment   add comment to notification e-mail
 131          -k max       keep file max days on fex server
 132          -D           delay auto-delete after download
 133          -K           no auto-delete after download
 134          -M           MIME-file (to be displayed in recipient\'s webbrowser)
 135          -o           overwrite mode, do not resume
 136          -a archive   put files in archive (.zip .7z .tar .tgz)
 137          -s stream    read data from pipe and upload it with stream name
 138 special options: -I          initialize ID file or show ID
 139                  -I account  add alternate ID data (secondary logins) to ID file
 140                  -l          list sent files numbers (# needed for -f -x -d -N)
 141                  -f \#        forward already uploaded file to another recipient
 142                  -x \#        use -C -k -D -K for already uploaded file
 143                  -d \#        delete file on fex server
 144                  -N \#        resend notification e-mail
 145                  -Q          check quotas
 146                  -T up:down  test internet speed with up and down MBs
 147                  -A          edit server address book (aliases)
 148                  -S          show server/user settings and auth-ID
 149                  -H          show hints, examples and more options
 150                  -V          show version and ask for upgrade
 151                  (# is a file number, see output from $0 -l)
 152 examples: $0 visualization.mpg framstag\@rus.uni-stuttgart.de
 153           $0 -a images.zip *.jpg webmaster\@flupp.org,metoo
 154           lshw | $0 -s hardware.list admin\@flupp.org
 155 EOD
 156 #   or: $0 -R FEX-URL e-mail
 157 #         -R FEX mail  self-register your e-mail address at FEX server
 158
 159   $hints = <<EOD;
 160 $0 hints and more options:
 161
 162 usage: $0 [options] file recipient(s)
 163
 164 Recipient can be a comma separated address list. Example:
 165   $0 big.file framstag\@rus.uni-stuttgart.de,webmaster\@flupp.org
 166
 167 Recipient can be an alias from your server address book
 168 (use "$0 -A" to edit it). Example:
 169   $0 big.file framstag
 170
 171 Recipient can be a SKEY URL, which you have received from a regular F*EX user.
 172 When using this URL you are a subuser of this full user and the file will be
 173 sent to him. Example:
 174   $0 big.file http://fex.rus.uni-stuttgart.de/fup?skey=4285f8cdd881626524fba686d5f0a83a
 175
 176 Recipient can be a GKEY URL, which you have received from a regular F*EX user.
 177 Using this URL you are a member of his group and the file will be sent to all
 178 members of this group. Example:
 179   $0 big.file http://fex.rus.uni-stuttgart.de/fup?gkey=50d26547b1e8c1110beb8748fc1d9444
 180
 181 When you use "FEX-URL/anonymous" as recipient and your F*EX administrator has
 182 allowed anonymous upload for your IP address then no auth-ID is needed.
 183
 184 "." as recipient means fex to yourself and show immediately the download URL
 185 (no notification e-mail will be sent). Example:
 186   $0 software.tar .
 187
 188 "//" as recipient means fex to yourself and create extra short download URL.
 189 Example:
 190   $0 software.tar //
 191
 192 If you want a Bcc of the notification e-mail then add '!bcc!' to the comment:
 193 fexsend -C '!bcc! for me and you' ...
 194
 195 Additional special options:
 196
 197   -. sends a short instead of a detailed notification e-mail
 198   -/ does not upload the file, but tells the server to link it
 199   -= uses an alias name as file name
 200   -# excludes files (# is list separator) from archive -a
 201   -n sends no notification e-mail, but shows the download URL immediately
 202   -q is quiet mode
 203   -r ADDRESS sets e-mail Reply-To ADDRESS
 204   -F activates female mode
 205   -U show authorized URL
 206   -+ is an undocumented feature - test it :-)
 207
 208 To manage your subuser and groups or forward or redirect files, use a
 209 webbrowser with the URL from "$0 -U", e.g.:  firefox \$($0 -U)
 210
 211 If you want to copy-forward an already uploaded file to another recipient,
 212 then you first have to query the file number with:
 213   $0 -l
 214 and then copy-forward it with:
 215   $0 -b # other\@address
 216 Where # is the file number.
 217
 218 You can list an uploaded file in more detail with
 219   $0 -l #
 220 Where # is the file number.
 221
 222 If you want to modify the keep time, comment or auto-delete behaviour of an
 223 already uploaded file then you first have to query the file number with:
 224   $0 -l
 225 and then for example set the keep time to 30 days with:
 226   $0 -x # -k 30
 227 Where # is the file number.
 228
 229 With option -a you can send several files or whole directories within a single
 230 archive file. The archive types tar and tgz are build on-the-fly (streaming)
 231 whereas archive types zip and 7z need a temporary archive file on local disk.
 232
 233 With option -s you can send any data coming from a pipe (STDIN) as a file
 234 without wasting local disc space.
 235
 236 With option -X you can specify any URL parameter, e.g.:
 237 fexsend -X autodelete=yes ...
 238 fexsend -X 'autodelete=no&locale=german' ...
 239
 240 For HTTPS you can set the environment variables:
 241 SSLVERIFY=1                 # activate server identity verification
 242 SSLVERSION=TLSv1            # this is the default
 243 SSLCAPATH=/etc/ssl/certs    # path to trusted (root) certificates
 244 SSLCAFILE=/etc/ssl/cert.pem # file with trusted (root) certificates
 245 SSLCIPHERLIST=HIGH:!3DES    # see http://www.openssl.org/docs/apps/ciphers.html
 246
 247 Partner program xx is an internet clipboard. See: xx -h
 248
 249 Partner program fexget is for downloading. See: fexget -h
 250
 251 For temporary usage of a HTTP proxy use:
 252   $0 -P your_proxy:port:chunksize_in_MB file recipient
 253 Example:
 254   $0 -P wwwproxy.uni-stuttgart.de.de:8080:1024 4GB.tar .
 255
 256 For temporary usage of an alternative F*EX server or user use:
 257   FEXID="FEXSERVER USER AUTHID" $0 file recipient
 258 Example:
 259   FEXID="fex.flupp.org gaga\@flupp.org blubb" $0 big.file framstag\@rus.uni-stuttgart.de
 260
 261 You can define aliases (and optional fexsend options) in \$HOME/.fex/config.pl:
 262   %alias = (
 263     'alias1' => 'user1\@domain1.org',
 264     'alias2' => 'user2\@domain2.org',
 265     'both'   => 'user1\@domain1.org,user2\@domain2.org',
 266     'extra'  => 'extra\@special.net:-i other -K -k 30',
 267   );
 268
 269 fexsend also respects aliases in $HOME/.mutt/aliases
 270 The alias priority is (descending):
 271 \$HOME/.fex/config.pl
 272 \$HOME/.mutt/aliases
 273 fexserver address book
 274
 275 In \$HOME/.fex/config.pl you can also set the SSL* environment variables and the
 276 \$opt_* variables, e.g.:
 277
 278 \$ENV{SSLVERSION} = 'TLSv1';
 279 \${'opt_+'} = 1;
 280 \$opt_m = 200;
 281 EOD
 282 }
 283
 284 my @rcamel = (
 285 '\e[A
 286      _  _  c*_)
 287     / \/ \//
 288  *=(  __  /
 289     \\\\/\\\\/
 290 ',
 291 "\e[A    \\\\/\\\\/ \n",
 292 "\e[A   //\\\\//\\\\\n"
 293 );
 294
 295 my @rrcamel = (
 296 '\e[A
 297  (_*p _  _
 298    \\\\/ \/ \\
 299     \  __  )=*
 300     //\\\\//\\\\
 301 ',
 302 "\e[A     \\\\/\\\\/ \n",
 303 "\e[A    //\\\\//\\\\\n"
 304 );
 305
 306 autoflush STDOUT;
 307 autoflush STDERR;
 308
 309 if ($windoof and not @ARGV and not $ENV{PROMPT}) {
 310   # restart with cmd.exe to have mouse cut+paste
 311   exec qw'cmd /k',$0,'-W';
 312   exit;
 313 }
 314
 315 unless (-d $fexhome) {
 316   mkdir $fexhome,0700 or die "$0: cannot create FEXHOME $fexhome - $!\n";
 317 }
 318
 319 unless (-d $tmpdir) {
 320   mkdir $tmpdir,0700 or die "$0: cannot create tmpdir $tmpdir - $!\n";
 321 }
 322
 323 my @_ARGV = @ARGV; # save arguments
 324
 325 our ($opt_q,$opt_h,$opt_H,$opt_v,$opt_m,$opt_c,$opt_k,$opt_d,$opt_l,$opt_I,
 326      $opt_K,$opt_D,$opt_u,$opt_f,$opt_a,$opt_C,$opt_R,$opt_M,$opt_L,$opt_Q,
 327      $opt_A,$opt_i,$opt_z,$opt_Z,$opt_b,$opt_P,$opt_x,$opt_X,$opt_V,$opt_U,
 328      $opt_s,$opt_o,$opt_g,$opt_F,$opt_n,$opt_r,$opt_S,$opt_N,$opt_T);
 329
 330 if ($xx) {
 331   $opt_q = 1 if @ARGV and $ARGV[-1] eq '--' and pop @ARGV or not -t STDOUT;
 332   $opt_h = $opt_v = $opt_m = $opt_I = 0;
 333   $opt_X = '';
 334   $_ = "$fexhome/config.pl"; require if -f;
 335   getopts('hvIm:') or die $usage;
 336 } else {
 337   if ($macos and not @ARGV) {
 338     &ask_file;
 339   }
 340   $opt_h = $opt_v = $opt_m = $opt_c = $opt_k = $opt_d = $opt_l = $opt_I = 0;
 341   $opt_H = $opt_K = $opt_D = $opt_R = $opt_M = $opt_L = $opt_Q = $opt_A = 0;
 342   $opt_x = $opt_o = $opt_g = $opt_V = $opt_U = $opt_F = $opt_n = $opt_q = 0;
 343   $opt_S = $opt_N = 0;
 344   ${'opt_@'} = ${'opt_!'} = ${'opt_+'} = ${'opt_.'} = ${'opt_/'} = 0;
 345   ${'opt_='} = ${'opt_#'} = '';
 346   $opt_u = $opt_f = $opt_a = $opt_C = $opt_i = $opt_b = $opt_P = $opt_X = '';
 347   $opt_s = $opt_r = $opt_T = '';
 348   $_ = "$fexhome/config.pl"; require if -f;
 349   getopts('hHvcdognVDKlILUARWMFzZqQS@!+./r:m:k:u:f:a:s:C:i:b:P:x:X:N:T:=:#:')
 350     or die $usage;
 351
 352   if ($opt_H) {
 353     print $hints;
 354     exit;
 355   }
 356
 357   if ($opt_V) {
 358     print "Version: $version\n";
 359     unless (@ARGV) {
 360       print "Upgrade fexsend? ";
 361       $_ = <STDIN>||'';
 362       if (/^y/i) {
 363         my $new = `wget -nv -O- http://fex.belwue.de/download/fexsend`;
 364         if ($new !~ /upgrade fexsend/) {
 365           die "$0: bad update\n";
 366         }
 367         system qw'cp -aL',$_0,$_0.'_old';
 368         exit $? if $?;
 369         open $_0,'>',$_0 or die "$0: cannot write $_0. - $!\n";
 370         print {$_0} $new;
 371         close $_0;
 372         exec $_0,qw'-V .';
 373       }
 374     }
 375     exit if "@ARGV" eq '.';
 376   }
 377
 378   if ($opt_K and $opt_D) {
 379     die "$0: you cannot use both options -D and -K\n";
 380   }
 381
 382   if ($opt_a and $opt_c) {
 383     die "$0: you cannot use both options -a and -c\n";
 384   }
 385
 386   if ($opt_a and $opt_s) {
 387     die "$0: you cannot use both options -a and -s\n";
 388   }
 389
 390   if ($opt_g and $opt_c) {
 391     $opt_c = 0;
 392   }
 393
 394   $opt_f ||= $opt_b;
 395   if ($opt_f and $opt_f !~ /^\d+$/) {
 396     die "$0: option -f needs a number, see $0 -l\n";
 397   }
 398
 399   if ($opt_I and $opt_R) {
 400     die "$0: you cannot use both options -I and -R\n";
 401   }
 402
 403   # $opt_C is COMMENT command in F*EX protocol
 404   $opt_C =
 405     ($opt_d)            ? 'DELETE':
 406     ($opt_l or $opt_L)  ? 'LIST':
 407     ($opt_Q)            ? 'CHECKQUOTA':
 408     ($opt_S)            ? 'LISTSETTINGS':
 409     ($opt_Z)            ? 'RECEIVEDLOG':
 410     ($opt_z)            ? 'SENDLOG':
 411     (${'opt_!'})        ? 'FOPLOG':
 412   $opt_C;
 413
 414   $opt_D =
 415     ($opt_D) ? 'DELAY':
 416     ($opt_K) ? 'NO':
 417   $opt_D;
 418 }
 419
 420 &get_ssl_env;
 421
 422 if ($opt_h) {
 423   female_mode("show help?") if $opt_F;
 424   print $usage;
 425   exit;
 426 }
 427
 428
 429 if ($opt_R) {
 430   &register;
 431   exit;
 432 }
 433
 434
 435 die $usage if $opt_m and $opt_m !~ /^\d+/;
 436
 437 if ($opt_P) {
 438   if ($opt_P =~ /^([\w.-]+:\d+)(:(\d+))?/) {
 439     $proxy = $1;
 440     $chunksize = $3 || 0;
 441   } else {
 442     die "$0: proxy must be: SERVER:PORT\n";
 443   }
 444 }
 445
 446 if ($FEXID = $ENV{FEXID}) {
 447   $FEXID = decode_b64($FEXID) if $FEXID !~ /\s/;
 448   ($fexcgi,$from,$id) = split(/\s+/,$FEXID);
 449 } else {
 450   if ($windoof and not -f $idf) { &init_id }
 451   if (open $idf,$idf) {
 452     &get_id($idf);
 453     close $idf;
 454   }
 455 }
 456
 457 if ($xx) {
 458   # convert old idxx file
 459   if ($idf and open $idf,$idf.'xx') {
 460     &get_id($idf);
 461     close $idf;
 462     if (open $idf,'>>',$idf) {
 463       print {$idf} "\n[xx]\n",
 464                    "$fexcgi\n",
 465                    "$from\n",
 466                    "$id\n";
 467       close $idf;
 468       unlink $idf.'xx';
 469     }
 470   }
 471
 472   # special xx ID?
 473   if ($FEXXX = $ENV{FEXXX}) {
 474     $FEXXX = decode_b64($FEXXX) if $FEXXX !~ /\s/;
 475     ($fexcgi,$from,$id) = split(/\s+/,$FEXXX);
 476   } elsif (open $idf,$idf) {
 477     while (<$idf>) {
 478       if (/^\[xx\]/) {
 479         $proxy = $proxy_prefix = '';
 480         &get_id($idf);
 481         last;
 482       }
 483     }
 484     close $idf;
 485   }
 486
 487 } else {
 488
 489   # alternativ ID?
 490   if ($opt_i) {
 491     $proxy = $proxy_prefix = '';
 492     open $idf,$idf or die "$0: cannot open $idf - $!\n";
 493     while (<$idf>) {
 494       if (/^\[$opt_i\]/) {
 495         &get_id($idf);
 496         last;
 497       }
 498     }
 499     close $idf;
 500     die "$0: no [$opt_i] in $idf\n" unless $_;
 501   }
 502 }
 503
 504 if ($opt_I) {
 505   if ($xx) { &show_id }
 506   else     { &init_id }
 507   exit;
 508 }
 509
 510 if ($opt_T) {
 511   my ($up,$down);
 512
 513   $usage = "usage: $0 -T MB_up[:MB_down] [fexserver]\n";
 514   if ($opt_T =~ /^(\d+)$/) {
 515     $up = $down = $1;
 516   } elsif ($opt_T =~ /^(\d+):(\d+)$/) {
 517     $up = $1;
 518     $down = $2;
 519   } else {
 520     die $usage;
 521   }
 522
 523   if (@ARGV) {
 524     nettest($ARGV[0],$up,$down);
 525   } elsif ($fexcgi) {
 526     nettest($fexcgi,$up,$down);
 527   } else {
 528     nettest('fex.belwue.de',$up,$down);
 529   }
 530   exit;
 531 }
 532
 533 if (@ARGV > 1 and $ARGV[-1] =~ /(^|\/)anonymous/) {
 534   $fexcgi = $1 if $ARGV[-1] =~ s:(.+)/::;
 535   die "usage: $0 [options] file FEXSERVER/anonymous\n" unless $fexcgi;
 536   $anonymous = $from = 'anonymous';
 537   $sid = $id = 'ANONYMOUS';
 538 } elsif (@ARGV > 1 and $id eq 'PUBLIC') {
 539   $public = $sid = $id;
 540 } elsif (@ARGV > 1 and $ARGV[-1] =~ m{^(https?://[\w.-]+(:\d+)?/fup\?[sg]key=\w+)}) {
 541   $fexcgi = $1;
 542   $skey = $1 if $fexcgi =~ /skey=(\w+)/;
 543   $gkey = $1 if $fexcgi =~ /gkey=(\w+)/;
 544 } else {
 545
 546   $fexcgi = $opt_u if $opt_u;
 547
 548   if (not -e $idf and not ($fexcgi and $from and $id)) {
 549     die "$0: no ID file $idf found, use \"fexsend -I\" to create it\n";
 550   }
 551
 552   unless ($fexcgi) {
 553     die "$0: no FEX URL found, use \"$0 -u URL\" or \"$0 -I\"\n";
 554   }
 555
 556   unless ($from and $id) {
 557     die "$0: no sender found, use \"$0 -f FROM:ID\" or \"$0 -I\"\n";
 558   }
 559
 560   if ($fexcgi !~ /^http/) {
 561     if ($fexcgi =~ /:443/) { $fexcgi = "https://$fexcgi" }
 562     else                   { $fexcgi = "http://$fexcgi" }
 563   }
 564
 565 }
 566
 567 $server = $fexcgi;
 568
 569 $port = 80;
 570 $port = 443 if $server =~ s{https://}{};
 571 $port = $1  if $server =~ s/:(\d+)//;
 572
 573 if ($port == 443) {
 574   # $opt_s and die "$0: cannot use -s with https due to stunnel bug\n";
 575   # $opt_g and die "$0: cannot use -g with https due to stunnel bug\n";
 576   $https = $port;
 577 }
 578
 579 $server =~ s{http://}{};
 580 $server =~ s{/.*}{};
 581
 582 # $chunksize = 4*k unless $chunksize;
 583 $chunksize *= M;
 584
 585 if ($proxy) {
 586   if    ($port == 80)  { $proxy_prefix = "http://$server" }
 587   elsif ($port != 443) { $proxy_prefix = "http://$server:$port" }
 588 }
 589
 590 # xx: special file exchange between own accounts
 591 if ($xx) {
 592   my $transferfile = "$tmpdir/STDFEX";
 593   # slot?
 594   if ($0 eq 'xxx') {
 595     $transferfile = "$tmpdir/xx:xxx";
 596   } elsif (@ARGV and $ARGV[0] =~ /^:([\w.=+-]+)$/) {
 597     $transferfile = "$tmpdir/xx:$1";
 598     shift @ARGV;
 599   }
 600   open my $lock,'>>',$transferfile
 601     or die "$0: cannot write $transferfile - $!\n";
 602   flock($lock,LOCK_EX|LOCK_NB)
 603     or die "$0: $transferfile is locked by another process\n";
 604   truncate $transferfile,0;
 605   if (not @ARGV and -t) {
 606     &get_xx($transferfile);
 607   } else {
 608     &send_xx($transferfile);
 609   }
 610   exit;
 611 }
 612
 613 # regular fexsend
 614
 615 &inquire if $windoof and not @ARGV and not
 616             ($opt_l or $opt_L or $opt_Q or $opt_A or $opt_U or $opt_I or
 617              $opt_f or $opt_x or $opt_N);
 618
 619 if (${'opt_.'}) {
 620   $opt_C = "!SHORTMAIL! $opt_C";
 621 }
 622
 623 if ($opt_n or $opt_C =~ /NOMAIL|!#!/) {
 624   $nomail = 'NOMAIL';
 625 }
 626
 627 unless ($skey or $gkey or $anonymous) {
 628   if (not $opt_q and (
 629     $opt_f||$opt_x||$opt_Q||$opt_l||$opt_L||$opt_U||$opt_z||$opt_Z||$opt_A
 630     ||$opt_d||${'opt_!'}||${'opt_@'})
 631   ) { warn "Server/User: $fexcgi/$from\n" }
 632 }
 633
 634 if    ($opt_V and not @ARGV)            { exit }
 635 if    ($opt_f)                          { &forward }
 636 elsif ($opt_x)                          { &modify }
 637 elsif ($opt_N)                          { &renotify }
 638 elsif ($opt_Q)                          { &query_quotas }
 639 elsif ($opt_S)                          { &query_settings }
 640 elsif ($opt_l or $opt_L)                { &list }
 641 elsif ($opt_U)                          { &show_URL }
 642 elsif ($opt_z or $opt_Z or ${'opt_!'})  { &get_log }
 643 elsif ($opt_A)                          { edit_address_book($from) }
 644 elsif (${'opt_@'})                      { &show_address_book }
 645 elsif ($opt_d and $anonymous)           { &purge }
 646 elsif ($opt_d and $ARGV[-1] =~ /^\d+$/) { &delete_file_number }
 647 else                                    { &send_fex }
 648
 649 exit;
 650
 651
 652 # initialize ID file or show ID
 653 sub init_id {
 654   my $tag;
 655   my $proxy = '';
 656
 657   if ($opt_I) {
 658     $tag = shift @ARGV;
 659     die $usage if @ARGV;
 660   }
 661
 662   $fexcgi = $from = $id = '';
 663
 664   unless (-d $fexhome) {
 665     mkdir $fexhome,0700 or die "$0: cannot create FEXHOME $fexhome - $!\n";
 666   }
 667
 668   # show ID
 669   if (not $tag and open $idf,$idf) {
 670     if ($opt_i) {
 671       while (<$idf>) {
 672         last if /^\[$opt_i\]/;
 673       }
 674     }
 675     $fexcgi = <$idf>;
 676     $from   = <$idf>;
 677     $id     = <$idf>;
 678     close $idf;
 679     if ($id) {
 680       chomp($fexcgi,$from,$id);
 681       $FEXID = encode_b64("$fexcgi $from $id");
 682       if (-t STDIN) {
 683         print "# hint: to edit the ID file $idf use \"$0 -I .\" #\n";
 684         print "export FEXID=$FEXID\n";
 685         print "history -d \$((HISTCMD-1));history -d \$((HISTCMD-1))\n";
 686       } else {
 687         print "FEXID=$FEXID\n";
 688       }
 689       exit;
 690     } else {
 691       die "$0: no ID data found\n";
 692     }
 693   }
 694
 695   if ($tag and $tag eq '.') { exec $ENV{EDITOR}||'vi',$idf }
 696
 697   if ($tag) { print "F*EX server URL for [$tag]: " }
 698   else      { print "F*EX server URL: " }
 699   $fexcgi = <STDIN>;
 700   $fexcgi =~ s/[\s\n]//g;
 701   die "you MUST provide a FEX-URL!\n" unless $fexcgi;
 702   if ($fexcgi =~ /\?/) {
 703     $from = $1 if $fexcgi =~ /\bfrom=(.+?)(&|$)/i;
 704     $id   = $1 if $fexcgi =~ /\bid=(.+?)(&|$)/i;
 705     # $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
 706     # $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
 707     die "$0: cannot use GKEY URL in ID file\n" if $fexcgi =~ /gkey=/i;
 708     die "$0: cannot use SKEY URL in ID file\n" if $fexcgi =~ /skey=/i;
 709     $fexcgi =~ s/\?.*//;
 710   }
 711   unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
 712     die "\"$fexcgi\" is not a legal FEX-URL!\n";
 713   }
 714   $fexcgi =~ s:/fup/*$::;
 715   print "proxy address (hostname:port or empty if none): ";
 716   $proxy = <STDIN>;
 717   $proxy =~ s/[\s\n]//g;
 718   if ($proxy =~ /^[\w.-]+:\d+$/) {
 719     $proxy = "!$proxy";
 720   } elsif ($proxy =~ /\S/) {
 721     die "wrong proxy address format\n";
 722   } else {
 723     $proxy = "";
 724   }
 725   if ($proxy) {
 726     print "proxy POST limit in MB (use 2048 if unknown): ";
 727     $_ = <STDIN>;
 728     if (/(\d+)/) {
 729       $proxy .= "[$1]";
 730     }
 731   }
 732   if ($skey) {
 733     $from = 'SUBUSER';
 734     $id = $skey;
 735   } elsif ($gkey) {
 736     $from = 'GROUPMEMBER';
 737     $id = $gkey;
 738   } else {
 739     unless ($from) {
 740       print "Your e-mail address as registered at $fexcgi: ";
 741       $from = <STDIN>;
 742       $from =~ s/[\s\n]//g;
 743       die "you MUST provide your e-mail address!\n" unless $from;
 744     }
 745     unless ($from =~ /^[_:=\w\-\.\/\@\%\+]+$/) {
 746       die "\"$from\" is not a legal e-mail address!\n";
 747     }
 748     unless ($id) {
 749       print "Your auth-ID for $from at $fexcgi: ";
 750       $id = <STDIN>;
 751       $id =~ s/[\s\n]//g;
 752       die "you MUST provide your ID!\n" unless $id;
 753     }
 754   }
 755   if (open $idf,'>>',$idf) {
 756     print {$idf} "\n[$tag]\n" if $tag and -s $idf;
 757     print {$idf} "$fexcgi$proxy\n",
 758                  "$from\n",
 759                  "$id\n";
 760     close $idf;
 761     print "data written to $idf\n";
 762   } else {
 763     die "$0: cannot write to $idf - $!\n";
 764   }
 765 }
 766
 767
 768 sub show_id {
 769   my ($fexcgi,$from,$id);
 770   if (open $idf,$idf) {
 771     $fexcgi = <$idf>;
 772     # $fexcgi = <$idf> if $fexcgi =~ /^\[.+\]/;
 773     $from   = <$idf>;
 774     $id     = <$idf>;
 775     while (<$idf>) {
 776       if (/^\[xx\]/) {
 777         $fexcgi = <$idf>;
 778         $from   = <$idf>;
 779         $id     = <$idf>;
 780       }
 781     }
 782     close $idf;
 783     die "$0: too few data in $idf" unless defined $id;
 784     chomp($fexcgi);
 785     chomp($from);
 786     chomp($id);
 787     $FEXXX = encode_b64("$fexcgi $from $id");
 788     if (-t STDIN) {
 789       print "export FEXXX=$FEXXX\n";
 790       print "history -d \$((HISTCMD-1));history -d \$((HISTCMD-1))\n";
 791     } else {
 792       print "FEXXX=$FEXXX\n";
 793     }
 794   } else {
 795     die "$0: cannot read $idf - $!\n";
 796   }
 797 }
 798
 799
 800 sub register {
 801   my $fs = shift @ARGV or die $usage;
 802   my $mail = shift @ARGV or die $usage;
 803   my $port;
 804   my ($server,$user,$id);
 805
 806   die "$0: $idf does already exist\n" if -e $idf;
 807
 808   if ($fs =~ /^https/) {
 809     die "$0: cannot handle https at this time\n";
 810   }
 811
 812   $fs =~ s{^http://}{};
 813   $fs =~ s{/.*}{};
 814   if ($fs =~ s/:(\d+)//) { $port = $1 }
 815   else                   { $port = 80 }
 816
 817   tcpconnect($fs,$port);
 818   sendheader("$fs:$port","GET $proxy_prefix/fur?user=$mail&verify=no HTTP/1.1");
 819   http_response();
 820
 821   # header
 822   while (<$SH>) {
 823     s/\r//;
 824     printf "<-- $_"if $opt_v;
 825     last if /^\s*$/;
 826   }
 827
 828   while (<$SH>) {
 829     s/\r//;
 830     printf "<-- $_"if $opt_v;
 831     if (m{http://(.*)/fup\?from=(.+)&ID=(.+)}) {
 832       $server = $1;
 833       $user = $2;
 834       $id = $3;
 835
 836       if (open F,">$idf") {
 837         print F "$server\n",
 838                 "$user\n",
 839                 "$id\n";
 840         close F;
 841         chmod 0600,$idf;
 842         print "user data written to $idf\n";
 843         print "you can now fex!\n";
 844         exit;
 845       } else {
 846         die "$0: cannot write to $idf - $!\n";
 847       }
 848     }
 849   }
 850
 851   die "$0: no account data received from F*EX server\n";
 852
 853 }
 854
 855
 856 # menu for MacOS users
 857 sub menu {
 858   my $key;
 859   my $new;
 860   local $_;
 861
 862   system 'clear';
 863   print "\n";
 864   print "fexsend-$version\n";
 865
 866   for (;;) {
 867     if (open $idf,$idf) {
 868       $fexcgi = getline($idf) and
 869       $from   = getline($idf) and
 870       $id     = getline($idf);
 871       close $idf;
 872       last if $id;
 873     }
 874     &set_ID;
 875   }
 876
 877   print "\n";
 878   print "$from on $fexcgi\n";
 879   print "\n";
 880
 881   for (;;) {
 882     print "\n";
 883     print "[s]  send a file or directory\n";
 884     print "[u]  update fexsend\n";
 885     print "[l]  change login data (user, server, auth-ID)\n";
 886     print "[h]  help\n";
 887     print "[q]  quit\n";
 888     print "\n";
 889     print "your choice: ";
 890     $key = ReadKey(0);
 891     if ($key eq 'q') {
 892       print "$key\n";
 893       print "\n";
 894       print "Type [Cmd]W to close this window.\n";
 895       exit;
 896     }
 897     if ($key eq 'h') {
 898       print "$key\n";
 899       print
 900         "\n".
 901         "With fexsend you can send files of any size to any e-mail address.\n".
 902         "\n".
 903         "At the recipient or file prompt [RETURN] brings you to this option menu.\n".
 904         "\n".
 905         "To send more than one file:\n".
 906         "When you enter * at the file prompt, you will be first asked for an archive name\n".
 907         "and then you can drag+drop multiple files.\n".
 908         "\n".
 909         "Do not forget to terminate each input line with [RETURN].\n".
 910         "\n".
 911         "See http://fex.rus.uni-stuttgart.de/ for more information.\n";
 912       next;
 913     }
 914     if ($key eq 'u') {
 915       print "$key\n";
 916       if ($0 =~ m:(^/client/|/sw/):) {
 917         print "\n";
 918         print "use swupdate to update fexsend!\n";
 919         next;
 920       }
 921       $new = $0.'.new';
 922       system "curl http://fex.belwue.de/download/fexsend>".quote($new);
 923       chmod 0755,$new;
 924       system qw'perl -c',$new;
 925       if ($? == 0) {
 926         rename $new,$0;
 927         exec $0;
 928       } else {
 929         print "\n";
 930         print "cannot install new fexsend\n";
 931       }
 932       next;
 933     }
 934     if ($key eq 'l') {
 935       print "$key\n";
 936       system 'clear';
 937       &set_ID;
 938       next;
 939     }
 940     if ($key eq 's' or $key eq "\n") {
 941       print "s\n";
 942       &ask_file;
 943       next;
 944     }
 945   }
 946   exit;
 947 }
 948
 949
 950 # for MacOS
 951 sub ask_file {
 952   my ($file,$comment,$recipient,$archive,$size,$cmd,$key);
 953   my @files;
 954   my $qfiles;
 955   local $_;
 956
 957   system 'clear';
 958
 959   &set_ID unless -s $idf;
 960
 961   print "\n";
 962   print "Enter [RETURN] after each input line.\n";
 963   print "\n";
 964
 965   for (;;) {
 966     print "Recipient(s): ";
 967     $recipient = <STDIN>;
 968     chomp $recipient;
 969     $recipient =~ s/^\s+//;
 970     $recipient =~ s/\s+$//;
 971     $recipient =~ s/[\s;,]+/,/g;
 972     &menu unless $recipient;
 973     last if $recipient =~ /\w/ or $recipient eq '.';
 974   }
 975
 976   for (;;) {
 977     print "\n";
 978     print "Drag a file into this window or hit [RETURN] ";
 979     print $archive ? "to continue.\n" : "for menu options.\n";
 980     print "File to send: ";
 981     $file = <STDIN>||'';
 982     chomp $file;
 983     $file =~ s/^\s+//;
 984     $file =~ s/ $// if $file !~ /\\ $/;
 985     &menu unless $file or $archive;
 986     if ($file eq '*') {
 987       print "Archive name: ";
 988       $archive = <STDIN>||'';
 989       chomp $archive;
 990       next unless $archive;
 991       $archive =~ s/^\s+//g;
 992       $archive =~ s/\s+$//g;
 993       $archive =~ s/[^\w=.+-]/_/g;
 994       next;
 995     }
 996     if ($file) {
 997       unless (-e $file) {
 998         $file =~ s/\\\\/\000/g;
 999         $file =~ s/\\//g;
1000         $file =~ s/\000/\\/g;
1001       }
1002       unless (-r $file) {
1003         print "\"$file\" is not readable\n";
1004         next;
1005       }
1006       my $qf = quote($file);
1007       if (`du -ms $qf` =~ /^(\d+)/) {
1008         $size += $1;
1009         printf "%d MB\n",$1;
1010       }
1011       if ($archive) {
1012         push @files,$file;
1013         next;
1014       }
1015     }
1016     if ($archive) {
1017       next unless @files;
1018       $qfiles = join(' ',map(quote($_),@files));
1019       if ($size < 2048) {
1020         $archive .= '.zip';
1021       } else {
1022         $archive .= '.tar';
1023       }
1024     }
1025     print "\n";
1026     print "Comment: ";
1027     $comment = <STDIN>||'';
1028     chomp $comment;
1029     print "\n";
1030     if ($comment =~ s/^:\s*-/-/) {
1031       $cmd = quote($0)." $comment ";
1032       if ($archive) {
1033         $cmd .= '-a '.quote($archive).' '.$qfiles;
1034       } else {
1035         $cmd .= quote($file);
1036       }
1037       $cmd .= ' '.quote($recipient);
1038       print $cmd,"\n";
1039       system $cmd;
1040     } else {
1041       print quote($0)." -C '$comment' ";
1042       if ($archive) {
1043         printf "-a %s %s %s\n",quote($archive),$qfiles,$recipient;
1044         system $0,'-C',$comment,'-a',$archive,@files,$recipient;
1045       } else {
1046         printf "%s %s\n",quote($file),$recipient;
1047         system $0,'-C',$comment,$file,$recipient;
1048       }
1049     }
1050     print "\n";
1051     print "[s]  send another file to $recipient\n";
1052     print "[n]  send another file to another recipient\n";
1053     print "[q]  quit\n";
1054     print "\n";
1055     print "your choice: ";
1056     for (;;) {
1057       $key = ReadKey(0);
1058       &ask_file if $key eq 'n';
1059       if ($key eq 's' or $key eq "\n") {
1060         print "s\n";
1061         last;
1062       }
1063       if ($key eq 'q') {
1064         print "$key\n";
1065         exit;
1066       }
1067     }
1068     $file = $comment = $archive = '';
1069     @files = ();
1070   }
1071 }
1072
1073
1074 sub set_ID {
1075   my ($server,$port,$user,$logo);
1076   local $_;
1077
1078   print "\n";
1079   for (;;) {
1080     print "F*EX server URL: ";
1081     $server = <STDIN>;
1082     $server =~ s/[\s\n]//g;
1083     if ($server =~ s:/fup/(\w+)$::) {
1084       $_ = decode_b64($1);
1085       if (/(from|user)=(.+)&id=(.+)/) {
1086         $user = $2;
1087         $id = $3;
1088       }
1089     }
1090     $server =~ s:/fup.*::;
1091     $server =~ s:/+$::;
1092     next if $server !~ /\w/;
1093     if ($server =~ s/^https:..// or $server =~ /:443/) {
1094       $server =~ s/:.*//;
1095       $port = 443;
1096       eval "use IO::Socket::SSL";
1097       if ($@) {
1098         print "\nno perl SSL modules installed - cannot use https\n\n";
1099         next;
1100       }
1101       $SH = IO::Socket::SSL->new(
1102         PeerAddr => $server,
1103         PeerPort => $port,
1104         Proto    => 'tcp',
1105         %SSL
1106       );
1107     } else {
1108       $server =~ s:^http.//::;
1109       if ($server =~ s/:(\d+)//) {
1110         $port = $1;
1111       } else {
1112         $port = 80;
1113       }
1114       $SH = IO::Socket::INET->new(
1115         PeerAddr => $server,
1116         PeerPort => $port,
1117         Proto    => 'tcp',
1118       );
1119     }
1120     unless ($SH) {
1121       print "\ncannot connect to $server:$port - $!\n\n";
1122       next;
1123     }
1124     sendheader(
1125       "$server:$port",
1126       "GET /logo.jpg HTTP/1.0",
1127       "Connection: close",
1128     );
1129     $_ = <$SH>||'';
1130     unless (/HTTP.1.1 200/) {
1131       print "\nbad server reply: $_\n";
1132       next;
1133     }
1134     while (<$SH>) { last if /^\s*$/ }
1135     local $/;
1136     $logo = <$SH>||'';
1137     close $SH;
1138     if (length $logo < 9999) {
1139       print "\n$server is not a F*EX server!\n\n";
1140       next;
1141     }
1142     open $logo,">$tmpdir/fex.jpg";
1143     print {$logo} $logo;
1144     close $logo;
1145     last;
1146   }
1147
1148   for (;;) {
1149     last if $user;
1150     print "Your login (e-mail address): ";
1151     $user = <STDIN>;
1152     $user =~ s/[\s\n]//g;
1153     if ($user !~ /.@[\w.-]+$/) {
1154       print "\"$user\" is not a valid e-mail address!\n";
1155       next;
1156     }
1157   }
1158
1159   for (;;) {
1160     last if $id;
1161     print "Your auth-ID for this account: ";
1162     $id = <STDIN>;
1163     $id =~ s/[\s\n]//g;
1164   }
1165
1166   open $idf,'>',$idf or die "$0: cannot write to $idf - $!\n";
1167   print {$idf} "$server\n",
1168                "$user\n",
1169                "$id\n";
1170   close $idf;
1171   print "\n";
1172   print "Login data written to $idf\n\n";
1173   print "fexing test file to $user:\n\n";
1174   system "$0 -o -M -C test $tmpdir/fex.jpg $user";
1175   print "\n";
1176   if ($? != 0) {
1177     print "fexsend failed, login data is invalid, try again\n";
1178     &set_ID;
1179   } else {
1180     print "fexsend test succeeded!\n";
1181     sleep 3;
1182   }
1183 }
1184
1185
1186
1187 sub nettest {
1188   my $url = shift;
1189   my $up = shift;
1190   my $down = shift;
1191   my $bs = 2**16;
1192   my ($length,$t0,$t1,$t2,$tt,$tb,$tc,$B,$kBs,$bt);
1193
1194   my $nettest = $sid = 'nettest';
1195
1196   $port ||= 80;
1197   if ($url =~ s:^https.//::) {
1198     $https = $port = 443;
1199   } else {
1200     $url =~ s:^http.//::;
1201     $port = $1 if $url =~ s/:(\d+)//;
1202   }
1203   $url =~ s/[\/:].*//;
1204   $server = $url;
1205
1206   if ($up) {
1207     serverconnect($server,$port);
1208     checkrecipient($nettest,$nettest);
1209     warn "$0: send to $server:$port\n";
1210     formdatapost(
1211       from      => $nettest,
1212       to        => $nettest,
1213       id        => $nettest,
1214       file      => $nettest,
1215       size      => $up*M,
1216       comment   => 'NOSTORE',
1217     );
1218   }
1219
1220   if ($down) {
1221     serverconnect($server,$port);
1222     warn "$0: receive from $server:$port\n";
1223     sendheader("$server:$port","GET $proxy_prefix/ddd/$down HTTP/1.0");
1224     $_ = <$SH>;
1225     die "$0: no response from fex server $server\n" unless $_;
1226     s/\r//;
1227
1228     if (/^HTTP\/[\d.]+ 2/) {
1229       warn "<-- $_" if $opt_v;
1230       while (<$SH>) {
1231         s/\r//;
1232         print "<-- $_" if $opt_v;
1233         last if /^$/;
1234         $length = $1 if /^Content-Length:\s*(\d+)/i;
1235       }
1236     } else {
1237       s/HTTP\/[\d.]+ \d+ //;
1238       die "$0: bad server reply: $_";
1239     }
1240
1241     unless ($length) {
1242       die "$0: no Content-Length header in server reply\n";
1243     }
1244
1245
1246     if (${'opt_+'}) {
1247       print $rrcamel[0];
1248       $tc = 0;
1249     }
1250
1251     $t0 = $t1 = $t2 = int(time);
1252     $B = 0;
1253     while ($B < $length) {
1254       $b = read $SH,$_,$bs or die "$0: cannot read after $B bytes - $!\n";
1255       # defined($_ = <$SH>) or die "$0: cannot read after $B bytes - $!\n";
1256       # $b = length;
1257       $B += $b;
1258       $bt += $b;
1259       $t2 = time;
1260       if (${'opt_+'} and int($t2*10)>$tc) {
1261         print $rrcamel[$tc%2+1];
1262         $tc = int($t2*10);
1263       }
1264       if (int($t2) > $t1) {
1265         $kBs = int($bt/k/($t2-$t1));
1266         $t1 = $t2;
1267         $bt = 0;
1268         printf STDERR "nettest: %d MB (%d%%) %d kB/s        \r",
1269           int($B/M),int(100*$B/$length),$kBs;
1270       }
1271     }
1272     close $SH;
1273
1274     $tt = $t2-$t0;
1275     $kBs = int($B/k/($tt||1));
1276     if (${'opt_+'}) {
1277       print $rrcamel[1];
1278       print $rrcamel[2];
1279     }
1280     printf STDERR "nettest: %d MB in %d s = %d kB/s        \n",
1281       int($B/M),$tt,$kBs;
1282   }
1283 }
1284
1285
1286 # read one key from terminal in raw mode
1287 sub ReadKey {
1288   my $key;
1289   local $SIG{INT} = sub { stty('reset'); exit };
1290
1291   stty('raw');
1292   # loop necessary for ESXi support
1293   while (not defined $key) {
1294     $key = getc(STDIN);
1295   }
1296   stty('reset');
1297   return $key;
1298 }
1299
1300
1301 sub stty {
1302   if (shift eq 'raw') {
1303     system qw'stty -echo -icanon eol',"\001";
1304   } else {
1305     system qw'stty echo icanon eol',"\000";
1306   }
1307 }
1308
1309
1310 sub send_xx {
1311   my $transferfile = shift;
1312   my $file = '';
1313   my (@r,@tar,$dir);
1314
1315   $SIG{PIPE} = $SIG{INT} = sub {
1316     unlink $transferfile;
1317     exit 3;
1318   };
1319
1320   if ($0 eq 'xxx') { @tar = qw'tar -cv' }
1321   else             { @tar = qw'tar -cvz' }
1322
1323   if (-t) {
1324     if ("@ARGV" eq '-') {
1325       # store STDIN to transfer file
1326       shelldo("cat >> $transferfile");
1327     } elsif (@ARGV) {
1328       print "making tar transfer file $transferfile :\n";
1329       # single file? then add this directly
1330       if (scalar @ARGV == 1) {
1331         # strip path if not ending with /
1332         if ($ARGV[0] =~ m:(.+)/(.+): and $2 !~ m:/$:) {
1333           ($dir,$file) = ($1,$2);
1334           chdir $dir or die "$0: $dir - $!\n";
1335         } else {
1336           $file = $ARGV[0];
1337         }
1338         if (-l $file) {
1339           shelldo(@tar,qw'--dereference -f',$transferfile,$file);
1340         } else {
1341           shelldo(@tar,'-f',$transferfile,$file);
1342         }
1343       } else {
1344         shelldo(@tar,'-f',$transferfile,@ARGV);
1345       }
1346       if ($?) {
1347         unlink $transferfile;
1348         if ($? == 2) {
1349           die "$0: interrupted making tar transfer file\n";
1350         } else {
1351           die "$0: error while making tar transfer file\n";
1352         }
1353       }
1354     }
1355   } else {
1356     # write input from pipe to transfer file
1357     shelldo("cat >> $transferfile");
1358   }
1359
1360   die "$0: no transfer file\n" unless -s $transferfile;
1361
1362   serverconnect($server,$port);
1363   query_sid($server,$port);
1364
1365   @r = formdatapost(
1366     from        => $from,
1367     to          => $from,
1368     id          => $sid,
1369     file        => $transferfile,
1370     comment     => 'NOMAIL',
1371     autodelete  => $transferfile =~ /STDFEX/ ? 'NO' : 'DELAY',
1372   );
1373
1374   # open P,'|w3m -T text/html -dump' or die "$0: w3m - $!\n";
1375   # print P @r;
1376   http_response(@r);
1377   if ($transferfile =~ /:/ and $0 ne 'xxx') {
1378     if ("@r" =~ /\s(X-)?Location: (http.*)\s/) {
1379       print "wget -O- $2 | tar xvzf -\n";
1380     }
1381   }
1382
1383   unlink $transferfile;
1384 }
1385
1386
1387 sub query_quotas {
1388   my (@r,$r);
1389   local $_;
1390
1391   female_mode("query quotas?") if $opt_F;
1392
1393   @r = formdatapost(
1394     from        => $from,
1395     to          => $from,
1396     id          => $sid,
1397     command     => $opt_C,
1398   );
1399   die "$0: no response from fex server $server\n" unless @r;
1400   $_ = shift @r;
1401   unless (/^HTTP.* 2/) {
1402     s:HTTP/[\d\. ]+::;
1403     die "$0: server response: $_\n";
1404   }
1405   if (($_) = grep(/^X-Sender-Quota/,@r) and /(\d+)\s+(\d+)/) {
1406     print "sender quota (used): $1 ($2) MB\n";
1407   } else {
1408     print "sender quota: unlimited\n";
1409   }
1410   if (($_) = grep(/^X-Recipient-Quota/,@r) and /(\d+)\s+(\d+)/) {
1411     print "recipient quota (used): $1 ($2) MB\n";
1412   } else {
1413     print "recipient quota: unlimited\n";
1414   }
1415 }
1416
1417
1418 sub query_settings {
1419   my (@r,$r);
1420   local $_;
1421
1422   female_mode("query settings?") if $opt_F;
1423
1424   if ($FEXID) {
1425     print "ID data from \$FEXID\n";
1426   } elsif (-f $idf) {
1427     print "ID data from $idf\n";
1428   } else {
1429     die "$0: found no ID\n";
1430   }
1431   print "server: $fexcgi\n";
1432   print "user: $from\n";
1433   print "auth-ID: $id\n";
1434   print "login URL: ";
1435   &show_URL;
1436
1437   @r = formdatapost(
1438     from        => $from,
1439     to          => $from,
1440     id          => $sid,
1441     command     => $opt_C,
1442   );
1443   die "$0: no response from fex server $server\n" unless @r;
1444   $_ = shift @r;
1445   unless (/^HTTP.* 2/) {
1446     s:HTTP/[\d\. ]+::;
1447     die "$0: server response: $_\n";
1448   }
1449   if (($_) = grep(/^X-Autodelete/,@r) and /:\s+(\w+)/) {
1450     print "autodelete: $1\n";
1451   }
1452   if (($_) = grep(/^X-Default-Keep/,@r) and /(\d+)/) {
1453     print "default keep: $1 days\n";
1454   }
1455   if (($_) = grep(/^X-Default-Locale/,@r) and /:\s+(\w+)/) {
1456     print "default locale: $1\n";
1457   }
1458   if (($_) = grep(/^X-MIME/,@r) and /:\s+(\w+)/) {
1459     print "display file with browser: $1\n";
1460   }
1461   if (($_) = grep(/^X-Sender-Quota/,@r) and /(\d+)\s+(\d+)/) {
1462     print "sender quota (used): $1 ($2) MB\n";
1463   } else {
1464     print "sender quota: unlimited\n";
1465   }
1466   if (($_) = grep(/^X-Recipient-Quota/,@r) and /(\d+)\s+(\d+)/) {
1467     print "recipient quota (used): $1 ($2) MB\n";
1468   } else {
1469     print "recipient quota: unlimited\n";
1470   }
1471 }
1472
1473
1474 # list spool
1475 sub list {
1476   my (@r,$r);
1477   my ($data,$dkey);
1478   my $n = 0;
1479   my $s = 1;
1480   my $a = shift @ARGV || '.';
1481   local $_;
1482
1483   female_mode("list spooled files?") if $opt_F;
1484
1485   if ($opt_l) {
1486     if ($a =~ /^\d+$/) {
1487       open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
1488       while (<$fexlist>) {
1489         if (/^\s*(\d+)\) (\w+) (.+)/ and $1 eq $a) {
1490           serverconnect($server,$port) unless $SH;
1491           sendheader(
1492             "$server:$port",
1493             "GET $proxy_prefix/fop/$2/$2?LIST HTTP/1.1",
1494           );
1495           $_ = <$SH>||'';
1496           s/\r//;
1497           print "<-- $_" if $opt_v;
1498           if (/^HTTP.* 200/) {
1499             print "<-- $_" if $opt_v;
1500             while (<$SH>) {
1501               s/\r//;
1502               if (/^\n/) {
1503                 print;
1504                 print while <$SH>;
1505               }
1506             }
1507           } elsif (s:HTTP/[\d\. ]+::) {
1508             die "$0: server response: $_";
1509           } else {
1510             die "$0: no response from fex server $server\n";
1511           }
1512           exit;
1513         }
1514       }
1515       die "$0: file \#$a not found in fexlist\n";
1516     }
1517   }
1518
1519   @r = formdatapost(
1520     from        => $from,
1521     to          => $opt_l ? '*' : $from,
1522     command     => $opt_C,
1523   );
1524   die "$0: no response from fex server $server\n" unless @r;
1525   $_ = shift @r;
1526   unless (/^HTTP.* 200/) {
1527     s:HTTP/[\d\. ]+::;
1528     die "$0: server response: $_\n";
1529   }
1530
1531   # list sent files
1532   if ($opt_l) {
1533     open $fexlist,">$fexlist" or die "$0: cannot write $fexlist - $!\n";
1534     foreach (@r) {
1535       next unless /<pre>/ or $data;
1536       $data = 1;
1537       last if m:</pre>:;
1538       if (/<a href=".*dkey=(\w+).*?">/) { $dkey = $1 }
1539       else                              { $dkey = '' }
1540 #      $_ = encode_utf8($_);
1541       s/<.*?>//g;
1542       s/&amp;/&/g;
1543       s/&quot;/\"/g;
1544       s/&lt;/</g;
1545       if (/^(to (.+) :)/) {
1546         $s = $2 =~ /$a/;
1547         print "\n$_\n" if $s;
1548         print {$fexlist} "\n$_\n";
1549       } elsif (m/(\d+) MB (.+)/) {
1550         $n++;
1551         printf "%4s) %8d MB %s\n","#$n",$1,$2 if $s;
1552         printf {$fexlist} "%3d) %s %s\n",$n,$dkey,$2;
1553       }
1554     }
1555     close $fexlist;
1556   }
1557
1558   # list received files
1559   if ($opt_L) {
1560     foreach (@r) {
1561       next unless /<pre>/ or $data;
1562       $data = 1;
1563       next if m:<pre>:;
1564       last if m:</pre>:;
1565       if (/(from .* :)/) {
1566         print "\n$1\n";
1567       }
1568       if (m{(\d+) (MB.*)<a href="(https?://.*/fop/\w+/.+)">(.+)</a>( ".*")?}) {
1569         printf "%8d %s%s%s\n",$1,$2,$3,($5||'');
1570       }
1571     }
1572   }
1573 }
1574
1575
1576 sub show_URL {
1577   printf "%s/fup/%s\n",$fexcgi,encode_b64("from=$from&id=$id");
1578 }
1579
1580
1581 sub get_log {
1582   my (@r);
1583   local $_;
1584
1585   @r = formdatapost(
1586     from        => $from,
1587     to          => $from,
1588     id          => $sid,
1589     command     => $opt_C,
1590   );
1591   die "$0: no response from fex server $server\n" unless @r;
1592   $_ = shift @r;
1593   unless (/^HTTP.* 200/) {
1594     s:HTTP/[\d\. ]+::;
1595     die "$0: server response: $_\n";
1596   }
1597   while (shift @r) {}
1598   foreach (@r) { print "$_\n" }
1599 }
1600
1601
1602 sub show_address_book {
1603   my (%AB,@r);
1604   my $alias;
1605   local $_;
1606
1607   %AB = query_address_book($server,$port,$from);
1608   foreach $alias (sort keys %AB) {
1609     next if $alias eq 'ADDRESS_BOOK';
1610     $_ = sprintf "%s = %s (%s) # %s\n",
1611                  $alias,
1612                  $AB{$alias},
1613                  $AB{$alias}->{options},
1614                  $AB{$alias}->{comment};
1615     s/ \(\)//;
1616     s/ \# $//;
1617     print;
1618   }
1619 }
1620
1621
1622 sub purge {
1623   die "$0: not yet implemented\n";
1624 }
1625
1626
1627 sub delete_file_number {
1628   my ($to,$file);
1629
1630   while (@ARGV) {
1631     $opt_d = shift @ARGV;
1632     die "usage: $0 -d #\n" if $opt_d !~ /^\d+$/;
1633
1634     open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
1635     while (<$fexlist>) {
1636       if (/^to (.+\@.+) :/) {
1637         $to = $1;
1638       } elsif (/^\s*(\d+)\) (\w+) (.+)/ and $1 eq $opt_d) {
1639         serverconnect($server,$port) unless $SH;
1640         sendheader(
1641           "$server:$port",
1642           "GET $proxy_prefix/fop/$2/$2?DELETE HTTP/1.1",
1643         );
1644         $_ = <$SH>||'';
1645         s/\r//;
1646         print "<-- $_" if $opt_v;
1647         if (/^HTTP.* 200/) {
1648           while (<$SH>) {
1649             s/\r//;
1650             last if /^\n/; # ignore HTML output
1651             print "<-- $_" if $opt_v;
1652             if (/^X-File:.*\/(.+)/) {
1653               printf "%s deleted\n",decode_utf8(urldecode($1));
1654             }
1655           }
1656           undef $SH;
1657         } elsif (s:HTTP/[\d\. ]+::) {
1658           die "$0: server response: $_";
1659         } else {
1660           die "$0: no response from fex server $server\n";
1661         }
1662         last;
1663       }
1664     }
1665     close $fexlist;
1666     sleep 1; # do not overrun server
1667   }
1668
1669   exit;
1670 }
1671
1672
1673 sub delete_file {
1674   my ($from,$to,$file) = @_;
1675   local $_;
1676
1677   unless ($SH) {
1678     serverconnect($server,$port);
1679     query_sid($server,$port) unless $anonymous;
1680   }
1681
1682   $file = urlencode($file);
1683   sendheader(
1684     "$server:$port",
1685     "GET $proxy_prefix/fop/$to/$from/$file?id=$sid&DELETE HTTP/1.1",
1686   );
1687
1688   while (<$SH>) {
1689     s/\r//;
1690     printf "<-- $_"if $opt_v;
1691     last if /^\s*$/;
1692   }
1693 }
1694
1695
1696 sub urlencode {
1697   local $_ = shift;
1698   s/([^_=:,;<>()+.\w\-])/'%'.uc(unpack("H2",$1))/ge;
1699   return $_;
1700 }
1701
1702
1703 sub send_fex {
1704   my @to;
1705   my $file = '';
1706   my @files = ();
1707   my ($data,$aname,$alias);
1708   my (@r,$r);
1709   my $t0 = time;
1710   my $transferfile;
1711   my @transferfiles;
1712   local $_;
1713
1714   if ($from =~ /^SUBUSER|GROUPMEMBER$/) {
1715     $to = '_';
1716   } else {
1717     # look for single @ in arguments
1718     for (my $i=1; $i<$#ARGV; $i++) {
1719       if ($ARGV[$i] eq '@') {
1720         $ARGV[$i] = join(',',@ARGV[$i+1 .. $#ARGV]);
1721         $#ARGV = $i;
1722         last;
1723       }
1724     }
1725     $to = pop @ARGV or die $usage;
1726     if ($to eq '.') {
1727       $to = $from;
1728       $nomail = $opt_C ||= 'NOMAIL';
1729     }
1730     if ($to eq ':') {
1731       $to = $from;
1732       $nomail = $opt_C ||= 'NOMAIL';
1733     }
1734     if ($opt_g and $to =~ /,/) {
1735       die "$0: encryption is supported to only one recipient\n";
1736     }
1737     if ($to =~ m{^https?://.*/fup\?skey=(\w+)}) {
1738       $from = 'SUBUSER';
1739       $to = '_';
1740       $id = $1;
1741     }
1742     if ($to =~ m{^https?://.*/fup\?gkey=(\w+)}) {
1743       $from = 'GROUPMEMBER';
1744       $to = '_';
1745       $id = $1;
1746     }
1747   }
1748   @to = split(',',lc($to));
1749
1750   die $usage unless @ARGV or $opt_a or $opt_s;
1751   die $usage if $opt_s and @ARGV;
1752
1753   # early serverconnect necessary for X-Features info
1754   serverconnect($server,$port);
1755
1756   if ($anonymous) {
1757     my $aok;
1758     sendheader("$server:$port","OPTIONS /FEX HTTP/1.1");
1759     $_ = <$SH>||'';
1760     s/\r//;
1761     die "$0: no response from fex server $server\n" unless $_;
1762     print "<-- $_" if $opt_v;
1763     if (/^HTTP.* 201/) {
1764       while (<$SH>) {
1765         s/\r//;
1766         print "<-- $_" if $opt_v;
1767         last unless /\w/;
1768         $aok = $_ if /X-Features:.*ANONYMOUS/;
1769       }
1770       die "$0: no anonymous support on server $server\n" unless $aok;
1771     } else {
1772       die "$0: bad response from server $server : $_\n";
1773     }
1774   } elsif ($public) {
1775   } else {
1776
1777     query_sid($server,$port);
1778
1779     if ($from eq 'SUBUSER') {
1780       $skey = $sid;
1781       # die "skey=$skey\nid=$id\nsid=$sid\n";
1782     }
1783
1784     if ($from eq 'GROUPMEMBER') {
1785       $gkey = $sid;
1786     }
1787
1788     if ($to eq '.') {
1789       @to = ($from);
1790       $opt_C ||= 'NOMAIL';
1791     } elsif ($to =~ m:^(//.*):) {
1792       my $xkey = $1;
1793       if ($features =~ /XKEY/) {
1794         @to = ($from);
1795         $opt_C = $xkey;
1796       } else {
1797         die "$0: server does not support XKEY\n";
1798       }
1799     } elsif (grep /^[^@]*$/,@to and not $skey and not $gkey) {
1800       %AB = query_address_book($server,$port,$from);
1801       if ($proxy) {
1802         serverconnect($server,$port);
1803         query_sid($server,$port);
1804       }
1805       foreach $to (@to) {
1806         # alias in local config?
1807         if ($alias{$to}) {
1808           if ($alias{$to} =~ /(.+?):(.+)/) {
1809             my $ato = $1;
1810             my $opt = $2;
1811             my @argv = @_ARGV;
1812             pop @argv;
1813             # special extra upload
1814             system $0,split(/\s/,$opt),@argv,$ato;
1815             $to = '';
1816           } else {
1817             $to = $alias{$to};
1818           }
1819         }
1820         # alias in server address book?
1821         elsif ($AB{$to}) {
1822           # do not substitute alias with expanded addresses because then
1823           # keep and autodelete options from address book will get lost
1824           # $to = $AB{$to};
1825         }
1826         # look for mutt aliases
1827         elsif ($to !~ /@/ and $to ne $from) {
1828           $to = get_mutt_alias($to);
1829         }
1830       }
1831     }
1832
1833     $to = join(',',grep /./,@to) or exit;
1834     # warn "Server/User: $fexcgi/$from\n" unless $opt_q;
1835
1836     if (
1837       not $skey and not $gkey
1838       and $from ne $to
1839       and $features =~ /CHECKRECIPIENT/
1840       and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/
1841     ) {
1842       checkrecipient($from,$to);
1843       if ($proxy) {
1844         serverconnect($server,$port);
1845         query_sid($server,$port);
1846       }
1847     }
1848   }
1849
1850   if (@ARGV > 1 and not ($opt_a or $opt_s or $opt_d)) {
1851     print "Archive name (name.tar, name.tgz or name.zip) or [RETURN] to send file for file:\n";
1852     $opt_a = <STDIN>;
1853     $opt_a =~ s/^\s+//;
1854     $opt_a =~ s/\s+$//;
1855     $opt_a =~ s/\//_/g;
1856   }
1857
1858   if ($macos and not $opt_a and -d "@ARGV") {
1859     my $dir = "@ARGV";
1860     my $qdir = quote($dir);
1861     if (`du -s $qdir` =~ /^(\d+)/ and $1 < 2**21) {
1862       $opt_a = "$dir.zip";
1863     } else {
1864       $opt_a = "$dir.tar";
1865     }
1866   }
1867
1868   if ($opt_s) {
1869     $opt_s =~ s/^=//;
1870     $opt_s =~ s:.*/::;
1871     $opt_s =~ s/[^\w_.+-]/_/g;
1872     @files = ($opt_s);
1873   } elsif ($opt_a) {
1874     $opt_a =~ s/^=//;
1875     $opt_a =~ s:.*/::;
1876     $opt_a =~ s/[^\w_.+-]/_/g;
1877     if ($opt_a =~ /(.+)\.(zip|tar|tgz|7z)$/) {
1878       $aname = $1;
1879       $atype = $2;
1880     } else {
1881       die "$0: archive name must be one of ".
1882           "$opt_a.tar $opt_a.tgz $opt_a.zip\n";
1883     }
1884     # no file argument left?
1885     unless (@ARGV) {
1886       # use file name as archive name
1887       push @ARGV,$aname;
1888       $opt_a =~ s:/+$::g;
1889       $opt_a =~ s:.*/::g;
1890     }
1891     foreach my $file (@ARGV) {
1892       die "$0: cannot read \"$file\"\n" unless -l $file or -r $file;
1893     }
1894     $opt_a .= ".$atype" if $opt_a !~ /\.$atype$/;
1895     $transferfile = "$tmpdir/$opt_a";
1896     unlink $transferfile;
1897     print "Making fex archive ($opt_a):\n";
1898     if ($atype eq 'zip') {
1899       if ($windoof) {
1900         # if ($opt_c) { system(qw'7z a -tzip',$transferfile,@ARGV) }
1901         # else        { system(qw'7z a -tzip -mm=copy',$transferfile,@ARGV) }
1902         system(qw'7z a -tzip',$transferfile,@ARGV);
1903         @files = ($transferfile);
1904       } elsif ($macos and scalar(@ARGV) == 1) {
1905         ## ditto-zip is now handled by formdatapost()
1906         system 'true';
1907         @files = ($opt_a);
1908       } else {
1909         # zip archives must be < 2 GB, so split as necessary
1910         @files = zipsplit($transferfile,@ARGV);
1911         if (scalar(@files) == 1) {
1912           $transferfile = $files[0];
1913           $transferfile =~ s/_1.zip$/.zip/;
1914           rename $files[0],$transferfile;
1915           @files = ($transferfile);
1916         }
1917       }
1918       @transferfiles =  @files;
1919     } elsif ($atype eq '7z') {
1920       # http://www.7-zip.org/
1921       my @X = (); # exclude list
1922       if (${'opt_#'}) {
1923         foreach my $x (split('#',${'opt_#'})) {
1924           push @X,"-x!$x";
1925         }
1926       }
1927       if ($opt_c) { system(qw'7z a',@X,$transferfile,@ARGV) }
1928       else        { system(qw'7z a -t7z -mx0',@X,$transferfile,@ARGV) }
1929       @transferfiles = @files = ($transferfile);
1930     } elsif ($atype eq 'tar') {
1931       if ($windoof) {
1932         system(qw'7z a -ttar',$transferfile,@ARGV);
1933         @transferfiles = @files = ($transferfile);
1934       } else {
1935         ## tar is now handled by formdatapost()
1936         # system(qw'tar cvf',$transferfile,@ARGV);
1937         system 'true';
1938         @files = ($opt_a);
1939       }
1940     } elsif ($atype eq 'tgz') {
1941       if ($windoof) {
1942         die "$0: archive type tgz not available, use tar, zip or 7z\n";
1943       } else {
1944         ## tgz is now handled by formdatapost()
1945         # system(qw'tar cvzf',$transferfile,@ARGV);
1946         @files = ($opt_a);
1947       }
1948     } else {
1949       die "$0: unknown archive format \"$atype\"\n";
1950     }
1951
1952     if (@transferfiles) {
1953
1954       # error in making transfer archive?
1955       if ($?) {
1956         unlink @transferfiles;
1957         die "$0: $! - aborting upload\n";
1958       }
1959
1960       # maybe timeout, so make new connect
1961       if (time-$t0 >= $timeout) {
1962         serverconnect($server,$port);
1963         query_sid($server,$port) unless $anonymous;
1964       }
1965
1966     }
1967
1968   } else {
1969
1970     unless (@ARGV) {
1971       if ($windoof) {
1972         &inquire;
1973       } else {
1974         die $usage;
1975       }
1976     }
1977
1978     foreach (@ARGV) {
1979       my $file = $_;
1980       unless ($opt_d) {
1981         unless (-f $file) {
1982           if (-e $file) {
1983             die "$0: \"$file\" is not a regular file, try option -a\n"
1984           } else {
1985             die "$0: \"$file\" does not exist\n";
1986           }
1987         }
1988         die "$0: cannot read \"$file\"\n" unless -r $file;
1989       }
1990       push @files,$file;
1991     }
1992   }
1993
1994   if (${'opt_/'}) {
1995     foreach my $file (@files) {
1996       my @s = stat($file);
1997       unless (@s and ($s[2] & S_IROTH) and -r $file) {
1998         die "$0: \"$file\" is not world readable\n";
1999       }
2000     }
2001   }
2002
2003   foreach my $file (@files) {
2004     sleep 1;    # do not overrun server!
2005     unless (-s $file or $opt_d or $opt_a or $opt_s) {
2006       die "$0: cannot send empty file \"$file\"\n";
2007     }
2008     female_mode("send file $file?") if $opt_F;
2009     @r = formdatapost(
2010       from              => $from,
2011       to                => $to,
2012       replyto           => $opt_r,
2013       id                => $sid,
2014       file              => $file,
2015       keep              => $opt_k,
2016       comment           => $opt_C,
2017       autodelete        => $opt_D,
2018     );
2019
2020     if (not @r or not grep /\w/,@r) {
2021       die "$0: no response from server\n";
2022     }
2023     next if "@r" eq '0'; # already transfered
2024     if (($r) = grep /^ERROR:/,@r) {
2025       if ($anonymous and $r =~ /purge it/) {
2026         die "$0: file is already on server for $to - use another anonymous recipent\n";
2027       } elsif ($r =~ /timeout/i) {
2028         close $SH;
2029         retry("timed out");
2030       } else {
2031         $r =~ s/.*?:\s*//;
2032         $r =~ s/<.+?>//g;
2033         die "$0: server error: $r\n";
2034       }
2035     }
2036     unless ($opt_d) {
2037       if (scalar(@r) == 1) {
2038         die "$0: server error: @r\n";
2039       } else {
2040         if ($r[0] !~ /HTTP.1.. 2/) {
2041           if ($r[0] =~ /HTTP.[\s\d.]+(.+)/) {
2042             die "$0: server error: $1\n";
2043           } else {
2044             die "$0: server error:\n".join("\n",@r)."\n";
2045           }
2046         }
2047       }
2048     }
2049     if (($r) = grep /<h3>\Q$file/,@r) {
2050       $r =~ s/<.+?>//g;
2051       print "$r\n";
2052     }
2053     if ($opt_a !~ /^afex_\d+\.tar$/ and $file !~ /afex_\d+\.tar$/) {
2054       # print grep({s/^(X-Recipient:.*\((.+)\))/Parameters: $2\n/i} @r);
2055       my $nonot = 0;
2056       my $recipient = '';
2057       my $location = '';
2058       foreach (@r) {
2059         if (/^(X-)?(Recipient.*)/i) {
2060           $recipient = $2;
2061           if (/notification=no/i) { $nonot = 1 }
2062           else                    { $nonot = 0 }
2063         }
2064         if (/^(X-)?(Location.*)/i) {
2065           $location = $2;
2066         }
2067       }
2068       if ($from eq $to or $from =~ /^\Q$to\E@/i
2069           or $nomail or $anonymous or $nonot)
2070       {
2071         print "$recipient\n" if $recipient;
2072         print "$location\n"  if $location;
2073       }
2074     }
2075   }
2076
2077   # delete transfer tmp file
2078   unlink $transferfile if $transferfile;
2079 }
2080
2081
2082 sub forward {
2083   my (@r);
2084   my ($to,$n,$dkey,$file,$req);
2085   my ($status,$fp);
2086   local $_;
2087
2088   # look for single @ in arguments
2089   for (my $i=1; $i<$#ARGV; $i++) {
2090     if ($ARGV[$i] eq '@') {
2091       $ARGV[$i] = join(',',@ARGV[$i+1 .. $#ARGV]);
2092       $#ARGV = $i;
2093       last;
2094     }
2095   }
2096
2097   # if ($windoof and not @ARGV) { &inquire }
2098   $to = pop @ARGV or die $usage;
2099   $to = $from if $to eq '.';
2100   if ($to !~ /@/ and $to ne $from) {
2101     $to = get_mutt_alias($to);
2102   }
2103
2104   open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
2105   while (<$fexlist>) {
2106     if (/^\s*(\d+)\) (\w+) .\s*\d+ d. ([+-] )?(.+)/ and $1 eq $opt_f) {
2107       $n = $1;
2108       $dkey = $2;
2109       $file = $4;
2110       if ($file =~ s/ "(.*)"$//) {
2111         $opt_C ||= $1 if $1 ne 'NOMAIL';
2112       }
2113       last;
2114     }
2115   }
2116   close $fexlist;
2117
2118   unless ($n) {
2119     die "$0: file #$opt_f not found in fexlist\n";
2120   }
2121
2122   female_mode("forward file #$opt_f?") if $opt_F;
2123
2124   serverconnect($server,$port);
2125   query_sid($server,$port);
2126
2127   $req = "GET $proxy_prefix/fup?"
2128         ."from=$from&ID=$sid&to=$to&dkey=$dkey&command=FORWARD";
2129   $req .= "&comment=$opt_C"     if $opt_C;
2130   $req .= "&keep=$opt_k"        if $opt_k;
2131   $req .= "&autodelete=$opt_D"  if $opt_D;
2132   $req .= "&$opt_X"             if $opt_X;
2133   $req .= " HTTP/1.1";
2134   sendheader("$server:$port",$req);
2135   http_response();
2136   $fp = $file;
2137   $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename
2138   $status = 1;
2139   while (<$SH>) {
2140     $status = 0 if /"$fp"/;
2141     print if $opt_v or /"$fp"/;
2142   }
2143
2144   if ($status) {
2145     die "$0: server failed, rerun command with option -v\n";
2146   }
2147   exit;
2148 }
2149
2150
2151 sub renotify {
2152   my (@r);
2153   my ($to,$n,$dkey,$file,$req,$recipient);
2154   local $_;
2155
2156   die $usage if @ARGV;
2157
2158   open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
2159   while (<$fexlist>) {
2160     if (/^\s*(\d+)\) (\w+) .\s*\d+ d. (.+)/ and $1 eq $opt_N) {
2161       $n = $1;
2162       $dkey = $2;
2163       last;
2164     }
2165   }
2166   close $fexlist;
2167
2168   unless ($n) {
2169     die "$0: file #$opt_N not found in fexlist\n";
2170   }
2171
2172   female_mode("resend notification for file #$opt_N?") if $opt_F;
2173
2174   serverconnect($server,$port);
2175   query_sid($server,$port);
2176
2177   $req = "GET $proxy_prefix/fup?"
2178         ."from=$from&ID=$sid&dkey=$dkey&command=RENOTIFY"
2179         ." HTTP/1.1";
2180   sendheader("$server:$port",$req);
2181   http_response();
2182   while (<$SH>) {
2183     s/\r//;
2184     print "<-- $_" if $opt_v;
2185     last if /^\s*$/;
2186     if (/^X-Notify: (.+)\/(.+)\/(.+)/) {
2187       $recipient = $1;
2188       $file = $3;
2189     }
2190   }
2191
2192   if ($file) {
2193     print "notification e-mail for $file has been resent to $recipient\n";
2194   } else {
2195     if ($opt_v) {
2196       die "$0: server failed\n";
2197     } else {
2198       die "$0: server failed, rerun command with option -v\n";
2199     }
2200   }
2201
2202   exit;
2203 }
2204
2205
2206 sub modify {
2207   my (@r);
2208   my ($n,$dkey,$file,$req);
2209   local $_;
2210
2211   die $usage if @ARGV;
2212   die $usage unless $opt_C or $opt_k or $opt_D;
2213
2214   open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
2215   while (<$fexlist>) {
2216     if (/^\s*(\d+)\) (\w+) .\s*\d+ d. (.+)/ and $1 eq $opt_x) {
2217       $n = $1;
2218       $dkey = $2;
2219       $file = $3;
2220       $file =~ s/ "(.*)"$//;
2221       last;
2222     }
2223   }
2224   close $fexlist;
2225
2226   unless ($n) {
2227     die "$0: file #$opt_x not found in fexlist\n";
2228   }
2229
2230   female_mode("modify file #$opt_x?") if $opt_F;
2231
2232   serverconnect($server,$port);
2233   query_sid($server,$port);
2234
2235   $req = "GET $proxy_prefix/fup?"
2236         ."from=$from&ID=$sid&dkey=$dkey&command=MODIFY";
2237   $req .= "&comment=$opt_C"     if $opt_C;
2238   $req .= "&keep=$opt_k"        if $opt_k;
2239   $req .= "&autodelete=$opt_D"  if $opt_D;
2240   $req .= " HTTP/1.1";
2241   sendheader("$server:$port",$req);
2242   http_response();
2243   while (<$SH>) {
2244     if ($opt_v) {
2245       print "<-- $_";
2246     } else {
2247       print if /\Q$file/;
2248     }
2249   }
2250
2251   exit;
2252 }
2253
2254
2255 sub get_xx {
2256   my $transferfile = shift;
2257   my $ft = '';
2258   local $_;
2259
2260   # get transfer file from FEX server
2261   unless ($SH) {
2262     serverconnect($server,$port);
2263     query_sid($server,$port);
2264   }
2265
2266   xxget($from,$sid,$transferfile);
2267
2268   # empty file?
2269   unless (-s $transferfile) {
2270     unlink $transferfile;
2271     exit;
2272   }
2273
2274   # no further processing if delivering to pipe
2275   exec 'cat',$transferfile unless -t STDOUT;
2276
2277   if ($ft = `file $transferfile 2>/dev/null`) {
2278     if ($ft =~ /compressed/) {
2279       rename $transferfile,"$transferfile.gz";
2280       shelldo(ws("gunzip $transferfile.gz"));
2281     }
2282     $ft = `file $transferfile`;
2283   }
2284   # file command failed, so we look ourself into the file...
2285   elsif (open $transferfile,$transferfile) {
2286     read $transferfile,$_,4;
2287     close $transferfile;
2288     # gzip magic?
2289     if (/\x1F\x8B\x08\x00/) {
2290       rename $transferfile,"$transferfile.gz";
2291       shelldo(ws("gunzip $transferfile.gz"));
2292       # assuming tar
2293       $ft = 'tar archive';
2294     }
2295   }
2296   if ($ft =~ /tar archive/) {
2297     rename $transferfile,"$transferfile.tar";
2298     $transferfile .= '.tar';
2299     if ($opt_q) {
2300       $_ = 'y';
2301     } else {
2302       print "Files in transfer-container:\n\n";
2303       shelldo(ws("tar tvf $transferfile"));
2304       print "\nExtract these files? [Yn] ";
2305       $_ = <STDIN>;
2306     }
2307     if (/^n/i) {
2308       print "keeping $transferfile\n";
2309     } else {
2310       my $untar = "tar xvf";
2311       # if ($> == 0 and `tar --help 2>&1` =~ /gnu/) {
2312       #  $untar = "tar --no-same-owner -xvf";
2313       # }
2314       system("$untar $transferfile && rm $transferfile");
2315       die "$0: error while untaring, see $transferfile\n" if -f $transferfile;
2316     }
2317   } else {
2318     exec 'cat',$transferfile;
2319   }
2320   exit;
2321 }
2322
2323
2324 sub formdatapost {
2325   my %P = @_;
2326   my ($boundary,$filename,$length,$buf,$file,$fpsize,$resume,$seek,$nettest);
2327   my ($flink);
2328   my (@hh,@hb,@r,@pv,$to);
2329   my ($bytes,$b,$t,$bt);
2330   my ($t0,$t1,$t2,$tt,$tc);
2331   my $bs = 2**16;        # blocksize for reading and sending file
2332   my $fileid = int(time);
2333   my $chunk = 0;
2334   my $filesize = 0;
2335   my $connection = '';
2336   my $pct = '';
2337   my $dittodir = '.';
2338   my ($tar,$ditto,$aname,$atype,$list,$error,$location,$transferfile);
2339   local $_;
2340
2341   if (defined($file = $P{file})) {
2342
2343     $to = $AB{$P{to}} || $P{to}; # for gpg
2344
2345     # special file: stream from STDIN
2346     if ($opt_s) {
2347       $filename = encode_utf8($file);
2348       $filesize = -1;
2349     }
2350
2351     # compression?
2352     if ($opt_c) {
2353       my ($if,$of);
2354       $if = $file;
2355       $if =~ s/([^_\w\.\-])/\\$1/g;
2356       $transferfile = $tmpdir . '/' . basename($file) . '.gz';
2357       $of = $transferfile;
2358       $of =~ s/([^_\w\.\-])/\\$1/g;
2359       shelldo("gzip <$if>$of");
2360       $filesize = -s $transferfile;
2361       die "$0: cannot gzip \"$file\"\n" unless $filesize;
2362       $file = $transferfile;
2363     }
2364
2365     # special file: tar-on-the-fly
2366     if (not $windoof and $opt_a and $file =~ /(.+)\.(tar|tgz)$/) {
2367       $aname = $1;
2368       $atype = $2;
2369       $list  = "$tmpdir/$aname.list";
2370       $error = "$tmpdir/$aname.error";
2371       $tar = 'tar -cv';
2372       $tar .= 'z' if $atype eq 'tgz';
2373       if (`tar --help 2>/dev/null` =~ /--index-file/) {
2374         $tar .= " --index-file=$list -f-";
2375       } else {
2376         $tar .= " -f-";
2377       }
2378       if (${'opt_#'}) {
2379         foreach my $x (split('#',${'opt_#'})) {
2380           $tar .= " --exclude=$x";
2381         }
2382       }
2383       foreach (@ARGV) {
2384         $tar .= ' '.quote($_);
2385       }
2386       # print "calculating archive size... ";
2387       open $tar,"$tar 2>$error|" or die "$0: cannot run tar - $!\n";
2388       $t0 = int(time) if -t STDOUT;
2389       while ($b = read $tar,$_,$bs) {
2390         $filesize += $b;
2391         if ($t0) {
2392           $t1 = int(time);
2393           if ($t1>$t0) {
2394             printf "Archive size: %d MB\r",int($filesize/M);
2395             $t0 = $t1;
2396           }
2397         }
2398       }
2399       printf "Archive size: %d MB\n",int($filesize/M) if -t STDOUT;
2400       unless (close $tar) {
2401         $_ = '';
2402         if (open $error,$error) {
2403           local $/;
2404           $_ = <$error>;
2405           close $error;
2406         }
2407         unlink $list,$error;
2408         die "$0: tar error:\n$_";
2409       }
2410       $file = "$aname.$atype";
2411       $filename = encode_utf8($file);
2412       undef $SH; # force reconnect (timeout!)
2413     }
2414
2415     # special file: ditto-zip-on-the-fly
2416     # ditto: Can't archive multiple sources
2417     elsif ($macos and $opt_a and $file =~ /(.+)\.(zip)$/ and scalar(@ARGV) == 1) {
2418       $aname = $1;
2419       $atype = $2;
2420       $list  = "$tmpdir/$aname.list";
2421       $error = "$tmpdir/$aname.error";
2422       $ditto = 'ditto -c -k --sequesterRsrc --keepParent';
2423       if (-d "@ARGV" and "@ARGV" =~ m:^(.+)/(.+):) {
2424         $dittodir = $1;
2425         $file = $2;
2426         $file =~ s/([^\w\-\@\#%,.=+_:])/\\$1/g;
2427         $ditto .= ' '.$file;
2428       } else {
2429         foreach (@ARGV) {
2430           $file = $_;
2431           $file =~ s/([^\w\-\@\#%,.=+_:])/\\$1/g;
2432           $ditto .= ' '.$file;
2433         }
2434       }
2435       # print "calculating archive size... ";
2436       debug("cd $dittodir;$ditto -");
2437       open $ditto,"cd $dittodir;$ditto - 2>$error|"
2438         or die "$0: cannot run ditto - $!\n";
2439       $t0 = int(time) if -t STDOUT;
2440       while ($b = read $ditto,$_,$bs) {
2441         $filesize += $b;
2442         if ($t0) {
2443           $t1 = int(time);
2444           if ($t1>$t0) {
2445             printf "Archive size: %d MB\r",int($filesize/M);
2446             $t0 = $t1;
2447           }
2448         }
2449       }
2450       printf "Archive size: %d MB\n",int($filesize/M) if -t STDOUT;
2451       unless (close $ditto) {
2452         $_ = '';
2453         if (-s $error and open $error,$error) {
2454           local $/;
2455           $_ = <$error>;
2456           close $error;
2457         }
2458         unlink $list,$error;
2459         die "$0: ditto-zip error:\n$_";
2460       }
2461       unlink $list,$error;
2462       $file = "$aname.$atype";
2463       $filename = encode_utf8($file);
2464       undef $SH; # force reconnect (timeout!)
2465     }
2466
2467     elsif ($P{to} eq 'nettest') {
2468       $filename = $nettest = 'nettest';
2469       $filesize = $P{size};
2470       $fileid = 0;
2471     }
2472
2473     # single file
2474     else {
2475       $filename = encode_utf8(${'opt_='} || $file);
2476
2477       if ($windoof) {
2478         $filename =~ s/^[a-z]://;
2479         $filename =~ s/.*\\//;
2480       }
2481       $filename =~ s:.*/::;
2482       $filename =~ s:[\r\n]+: :g;
2483       if ($opt_d) {
2484         $filesize = 0;
2485       } elsif (not $opt_g and not $opt_s) {
2486         $filesize = -s $file or die "$0: \"$file\" is empty or not readable\n";
2487       }
2488     }
2489
2490     $filename .= '.gpg' if $opt_g;
2491
2492     unless ($opt_d or $nettest) {
2493       if ($opt_g) {
2494         $filesize = -1;
2495         $fileid = int(time);
2496       } else {
2497         if ($opt_a) {
2498           $fileid = md5_hex(fmd(@ARGV));
2499         } else {
2500           $fileid = fileid($file);
2501         }
2502       }
2503     }
2504
2505   } else {
2506     $file = $filename = '';
2507     $filesize = 0;
2508   }
2509
2510   FORMDATAPOST:
2511
2512   @hh = (); # HTTP header
2513   @hb = (); # HTTP body
2514   @r = ();
2515   $seek = 0;
2516   $resume = '';
2517   $chunk++;
2518
2519   unless ($SH) {
2520     serverconnect($server,$port);
2521     query_sid($server,$port) unless $anonymous or $nettest;
2522   }
2523
2524   $P{id} = $sid; # ugly hack!
2525
2526   $filename =~ s/\\/_/g; # \ is a illegal character for fexsrv
2527
2528   # ask server if this file has been already sent
2529   if ($file and not $xx and not $nettest) {
2530     if (not $opt_d and $opt_o) {
2531       # delete before overwrite
2532       delete_file($from,$to,$filename);
2533       serverconnect($server,$port);
2534       query_sid($server,$port) unless $anonymous;
2535       $P{id} = $sid; # ugly hack!
2536     } elsif (not($opt_s or $opt_g or $opt_d or $opt_l or $opt_L or ${'opt_/'})) {
2537       ($seek,$location) = query_file($server,$port,
2538         $frecipient||$P{to},$P{from},$P{id},$filename,$fileid);
2539       if ($filesize == $seek) {
2540         print "Location: $location\n" if $location and $nomail;
2541         warn "$0: $file has been already transferred\n";
2542         return 0;
2543       } elsif ($seek and $seek < $filesize) {
2544         $resume = " (resuming at byte $seek)";
2545       } elsif ($filesize <= $seek) {
2546         $seek = 0;
2547       }
2548     }
2549     if ($proxy) {
2550       sleep 1;    # do not overrun proxy
2551       serverconnect($server,$port);
2552     }
2553   }
2554
2555   # file part size
2556   if ($chunksize and $proxy and $port != 443
2557       and $filesize - $seek > $chunksize - $bs) {
2558     if ($features !~ /MULTIPOST/) {
2559       die sprintf("$0: server does not support chunked multi-POST needed for"
2560                   ." files > %d MB via proxy\n",$chunksize/M);
2561     }
2562     $opt_o = 0; # no overwriting mode for next chunks
2563     $fpsize = $chunksize - $bs;
2564   } else {
2565     $fpsize = $filesize - $seek;
2566   }
2567
2568   $boundary = randstring(48);
2569
2570   $P{seek} = $seek;
2571   $P{filesize} = $filesize;
2572
2573   # send HTTP POST variables
2574   if ($skey) {
2575     $P{skey} = $skey;
2576     @pv = qw'from to skey keep autodelete comment seek filesize';
2577   } elsif ($gkey) {
2578     $P{gkey} = $gkey;
2579     @pv = qw'from to gkey keep autodelete comment seek filesize';
2580   } else {
2581     @pv = qw'from to id replyto keep autodelete comment command seek filesize';
2582   }
2583   foreach my $v (@pv) {
2584     if ($P{$v}) {
2585       my $name = uc($v);
2586       push @hb,"--$boundary";
2587       push @hb,"Content-Disposition: form-data; name=\"$name\"";
2588       push @hb,"";
2589       # push @hb,encode_utf8($P{$v});
2590       push @hb,$P{$v};
2591     }
2592   }
2593
2594   # at last, POST the file
2595   if ($file) {
2596     push @hb,"--$boundary";
2597     push @hb,"Content-Disposition: form-data; name=\"FILE\"; filename=\"$filename\"";
2598     unless ($opt_d) {
2599       if ($opt_M) { push @hb,"Content-Type: application/x-mime" }
2600       else        { push @hb,"Content-Type: application/octet-stream" }
2601       if (${'opt_/'}) {
2602         $flink = abs_path($file);
2603         push @hb,"Content-Location: $flink";
2604       } else {
2605         # push @hb,"Content-Length: " . ((-s $file||0) - $seek); # optional header!
2606         push @hb,"Content-Length: $fpsize"; # optional header! NOT filesize!
2607         push @hb,"X-File-ID: $fileid";
2608       }
2609       push @hb,"";
2610     }
2611     push @hb,"";
2612     # prevent proxy chunked mode reply
2613     $connection = "close";
2614   }
2615
2616   push @hb,"--$boundary--";
2617
2618   if ($fpsize < 0) {
2619     $length = $fpsize;
2620   } else {
2621     $length = length(join('',@hb)) + scalar(@hb)*2 + $fpsize;
2622   }
2623
2624   if ($file and not $opt_d) {
2625     if ($flink) { $hb[-2] = $flink }
2626     else        { $hb[-2] = '(file content)' }
2627   }
2628   # any other extra URL arguments
2629   my $opt_X = '';
2630   $opt_X = "?$::opt_X" if $::opt_X and $file;
2631
2632   # HTTP header
2633   push @hh,"POST $proxy_prefix/fup$opt_X HTTP/1.1";
2634   push @hh,"Host: $server:$port";
2635   push @hh,"User-Agent: $useragent";
2636   push @hh,"Content-Length: $length";
2637   push @hh,"Content-Type: multipart/form-data; boundary=$boundary";
2638   push @hh,"Connection: $connection" if $connection;
2639   push @hh,'';
2640
2641   if ($opt_v) {
2642     print "--> $_\n" foreach (@hh,@hb);
2643   }
2644
2645   $SIG{PIPE} = \&sigpipehandler;
2646 #    foreach $sig (keys %SIG) {
2647 #      eval '$SIG{$sig} = sub { print "\n!!! SIGNAL '.$sig.' !!!\n"; exit; }';
2648 #    }
2649
2650   if ($file) {
2651     pop @hb;
2652     pop @hb unless $flink;
2653     nvtsend(@hh,@hb) or do {
2654       warn "$0: server has closed the connection, reconnecting...\n";
2655       sleep 3;
2656       goto FORMDATAPOST; # necessary: new $sid ==> new @hh
2657     };
2658
2659     unless ($opt_d or $flink) {
2660
2661       $t0 = $t2 = int(time);
2662       $tt = $t0-1;
2663       $t1 = 0;
2664       $tc = 0;
2665
2666       if ($opt_s) {
2667         if ($opt_g) {
2668           open $file,"gpg -e -r $to|" or die "$0: cannot run gpg - $!\n";
2669         } else {
2670           open $file,'>&=STDIN' or die "$0: cannot open STDIN - $!\n";
2671         }
2672       } elsif ($tar) {
2673         if ($opt_g) {
2674           open $file,"$tar|gpg -e -r $to|" or die "$0: cannot run tar&gpg - $!\n";
2675         } else {
2676           open $file,"$tar|" or die "$0: cannot run tar - $!\n";
2677         }
2678         if (-t STDOUT) {
2679           $tpid = fork();
2680           if (defined $tpid and $tpid == 0) {
2681             sleep 1;
2682             if (open $list,$list) {
2683               # print "\n$tar|\n"; system "ls -l $list";
2684               while ($list) {
2685                 while (<$list>) {
2686                   print ' 'x(length($file)+40),"\r",$_;
2687                 }
2688                 sleep 1;
2689               }
2690             }
2691             exit;
2692           }
2693           $SIG{CHLD} = 'IGNORE';
2694         }
2695         if ($seek) {
2696           print "Fast forward to byte $seek (resuming)\n";
2697           readahead($file,$seek);
2698         }
2699       } elsif ($ditto) {
2700         $ditto =~ s/ditto/ditto -V/;
2701         open $file,"cd $dittodir;$ditto -|" or die "$0: cannot run ditto - $!\n";
2702         if ($seek) {
2703           print "Fast forward to byte $seek (resuming)\n";
2704           readahead($file,$seek);
2705         }
2706       } elsif ($nettest) {
2707         #
2708       } else {
2709         if ($opt_g) {
2710           my $fileq = quote($file);
2711           open $file,"gpg -e -r $to <$fileq|" or die "$0: cannot run gpg - $!\n";
2712         } else {
2713           open $file,$file or die "$0: cannot read \"$file\" - $!\n";
2714           seek $file,$seek,0;
2715         }
2716         binmode $file;
2717       }
2718
2719       $bytes = 0;
2720       autoflush $SH 0;
2721
2722       print $rcamel[0] if ${'opt_+'};
2723
2724       $buf = '#' x $bs if $nettest;
2725
2726       $SIG{ALRM} = sub { retry("timed out") };
2727
2728       while ($bytes < $fpsize) {
2729         if ($nettest) {
2730           $b = $bs;
2731         } else {
2732           $b = read $file,$buf,$bs;
2733           last if $b == 0;
2734         }
2735         alarm($timeout*2);
2736         if ($https) {
2737           print {$SH} $buf or &sigpipehandler;
2738         } else {
2739           syswrite $SH,$buf or &sigpipehandler;
2740         }
2741         alarm(0);
2742         $bytes += $b;
2743         if (not $nettest and $filesize > 0 and $bytes+$seek > $filesize) {
2744           if ($tpid) {
2745             kill 9,$tpid;
2746             unlink $list;
2747           }
2748           die "$0: \"$file\" filesize has grown while uploading\n";
2749         }
2750         $bt += $b;
2751         $t2 = time;
2752         if (${'opt_+'} and int($t2*10)>$tc) {
2753           print $rcamel[$tc%2+1];
2754           $tc = int($t2*10);
2755         }
2756         if (not $opt_q and -t STDOUT and int($t2)>$t1) {
2757           &sigpipehandler unless $SH->connected;
2758           # smaller block size is better on slow links
2759           $bs = 4096 if $t1 and $bs>4096 and $bytes/($t2-$t0)<65536;
2760           if ($filesize > 0) {
2761             $pct = sprintf "(%d%%)",int(($bytes+$seek)/$filesize*100);
2762           }
2763           if ($bytes>2*M and $bs>4096) {
2764             printf STDERR "%s: %d MB of %d MB %s %d kB/s        \r",
2765                    $opt_s||$opt_a||$file,
2766                    int(($bytes+$seek)/M),
2767                    int($filesize/M),
2768                    $pct,
2769                    int($bt/k/($t2-$tt));
2770           } else {
2771             printf STDERR "%s: %d kB of %d MB %s %d kB/s        \r",
2772                    $opt_s||$opt_a||$file,
2773                    int(($bytes+$seek)/k),
2774                    int($filesize/M),
2775                    $pct,
2776                    int($bt/k/($t2-$tt));
2777           }
2778           $t1 = $t2;
2779           # time window for transfer rate calculation
2780           if ($t2-$tt>10) {
2781             $bt = 0;
2782             $tt = $t2;
2783           }
2784         }
2785         last if $filesize > 0 and $bytes >= $fpsize;
2786         sleep 1 while ($opt_m and $bytes/k/(time-$t0||1) > $opt_m);
2787       }
2788
2789       close $file unless $nettest;
2790
2791       $tt = ($t2-$t0)||1;
2792
2793       print $rcamel[2] if ${'opt_+'};
2794
2795       # terminate tar verbose output job
2796       if ($tpid) {
2797         sleep 2;
2798         kill 9,$tpid;
2799         unlink $list;
2800       }
2801
2802       if ($fileid =~ /[a-z]/ and not ($opt_s or $opt_g)) {
2803         if ($opt_a) {
2804           if ($fileid ne md5_hex(fmd(@ARGV))) {
2805             print "\n" unless $opt_q;
2806             die "$0: files have been modified while uploading\n";
2807           }
2808         } else {
2809           if ($fileid ne fileid($file)) {
2810             print "\n" unless $opt_q;
2811             die "$0: file has been modified while uploading\n";
2812           }
2813         }
2814       }
2815
2816       unless ($opt_q) {
2817         if (not $chunksize and $bytes+$seek < $filesize) {
2818           die "$0: \"$file\" filesize has shrunk while uploading\n";
2819         }
2820
2821         if ($seek or $chunksize and $chunksize < $filesize) {
2822           if ($fpsize>2*M) {
2823             printf STDERR "%s: %d MB in %d s = %d kB/s",
2824                            $opt_s||$opt_a||$file,
2825                            int($bytes/M),
2826                            $tt,
2827                            int($bytes/k/$tt);
2828             if ($bytes+$seek == $filesize) {
2829               printf STDERR ", total %d MB\n",int($filesize/M);
2830             } else {
2831               printf STDERR ", chunk #%d : %d MB\n",
2832                             $chunk,int(($bytes+$seek)/M);
2833             }
2834           } else {
2835             printf STDERR "%s: %d kB in %d s = %d kB/s",
2836                           $opt_s||$opt_a||$file,
2837                           int($bytes/k),
2838                           $tt,
2839                           int($bytes/k/$tt);
2840             if ($bytes+$seek == $filesize) {
2841               printf STDERR ", total %d kB\n",int($filesize/k);
2842             } else {
2843               printf STDERR ", chunk #%d : %d kB\n",
2844                             $chunk,int(($bytes+$seek)/k);
2845             }
2846           }
2847         } else {
2848           if ($bytes>2*M) {
2849             printf STDERR "%s: %d MB in %d s = %d kB/s        \n",
2850                           $opt_s||$opt_a||$file,
2851                           int($bytes/M),
2852                           $tt,
2853                           int($bytes/k/$tt);
2854           } else {
2855             printf STDERR "%s: %d kB in %d s = %d kB/s        \n",
2856                           $opt_s||$opt_a||$file,
2857                           int($bytes/k),
2858                           $tt,
2859                           int($bytes/k/$tt);
2860           }
2861         }
2862
2863         if (-t STDOUT and not ($opt_s or $opt_g or $nettest)) {
2864           print STDERR "waiting for server ok..."
2865         }
2866       }
2867     }
2868
2869     autoflush $SH 1;
2870     print {$SH} "\r\n--$boundary--\r\n";
2871     # return if $nettest;
2872
2873     # special handling of streaming file because of stunnel tcp shutdown bug
2874     if ($opt_s or $opt_g) {
2875       close $SH;
2876       sleep 1;
2877       serverconnect($server,$port);
2878       query_sid($server,$port) unless $anonymous;
2879       ($seek,$location) = query_file($server,$port,$P{to},$P{from},$sid,
2880                                      $filename,$fileid);
2881       if ($seek != $bytes) {
2882         die "$0: streamed $bytes bytes but server received $seek bytes\n";
2883       }
2884       return "X-Location: $location\n";
2885     }
2886
2887     if ($flink) {
2888       $bytes = -s $flink;
2889       if ($bytes>2*M) {
2890         printf STDERR "%s: %d MB\n",$flink,int($bytes/M);
2891       } else {
2892         printf STDERR "%s: %d kB\n",$flink,int($bytes/k);
2893       }
2894     }
2895   } else {
2896     autoflush $SH 1;
2897     nvtsend(@hh,@hb);
2898   }
2899
2900   # SuSe: Can't locate object method "BINMODE" via package "IO::Socket::SSL::SSL_HANDLE"
2901   # binmode $SH,':utf8';
2902
2903   if (not $opt_q and $file and -t STDOUT) {
2904     print STDERR "\r                         \r";
2905   }
2906   while (<$SH>) {
2907     s/[\r\n]+//;
2908     print "<-- $_\n" if $opt_v;
2909     last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i;
2910     push @r,decode_utf8($_);
2911   }
2912
2913   if ($file) {
2914     close $SH;
2915     undef $SH;
2916     if ($proxy and $fpsize+$seek < $filesize) {
2917       goto FORMDATAPOST;
2918     }
2919   }
2920
2921   return @r;
2922 }
2923
2924
2925 sub randstring {
2926     my $n = shift;
2927     my @rc = ('A'..'Z','a'..'z',0..9 );
2928     my $rn = @rc;
2929     my $rs;
2930
2931     for (1..$n) { $rs .= $rc[int(rand($rn))] };
2932     return $rs;
2933 }
2934
2935
2936 sub zipsplit {
2937   my $zipbase = shift;
2938   my @files = @_;
2939   my @zipfiles = ();
2940   my $file;
2941   my ($zsize,$size,$n);
2942
2943   $zipbase =~ s/\.zip$//;
2944   map { s/([^_\w\+\-\.])/\\$1/g } @files;
2945
2946   open my $ff,"find @files|" or die "$0: cannot search for @_ - $!\n";
2947   @files = ();
2948
2949   zipfile: for (;;) {
2950     $n++;
2951     if ($n eq 10) {
2952       unlink @zipfiles;
2953       die "$0: too many zip-archives\n";
2954     }
2955     $zsize = 0;
2956     while ($file = <$ff>) {
2957       chomp $file;
2958       # next if -l $file or not -f $file;
2959       next unless -f $file;
2960       $size = -s $file;
2961       if ($size > 2147480000) {
2962         unlink @zipfiles;
2963         die "$0: \"$file\" too big for zip\n";
2964       }
2965       if ($zsize + $size > 2147000000) {
2966         push @zipfiles,zip($zipbase.'_'.$n.'.zip',@files);
2967         @files = ($file);
2968         next zipfile;
2969       } else {
2970         push @files,$file;
2971         $zsize += $size;
2972       }
2973     }
2974     close $ff;
2975     last;
2976   }
2977   push @zipfiles,zip($zipbase.'_'.$n.'.zip',@files);
2978   return @zipfiles;
2979 }
2980
2981
2982 sub zip {
2983   no strict 'refs';
2984   my $zip = shift;
2985   my $cmd;
2986   local $_;
2987
2988   unlink $zip;
2989   # if ($opt_c) { $cmd = "zip -@ $zip" }
2990   # else        { $cmd = "zip -0 -@ $zip" }
2991   $cmd = "zip -@ $zip";
2992   if (${'opt_#'}) {
2993     ${'opt_#'} =~ s/#/ /g;
2994     $cmd .= " -x ".${'opt_#'};
2995   }
2996   print $cmd,"\n" if $opt_v;
2997   open $cmd,"|$cmd" or die "$0: cannot create $zip - $!\n";
2998   foreach (@_) {
2999     print {$cmd} $_."\n";
3000     print "  $_\n" if $opt_v;
3001   }
3002   close $cmd or die "$0: zip failed - $!\n";
3003
3004   return $zip;
3005 }
3006
3007
3008 sub getline {
3009   my $file = shift;
3010   local $_;
3011
3012   while (<$file>) {
3013     chomp;
3014     s/^#.*//;
3015     s/\s+#.*//;
3016     s/^\s+//;
3017     s/\s+$//;
3018     return $_ if length($_);
3019   }
3020   return '';
3021 }
3022
3023
3024 sub query_file {
3025   my ($server,$port,$to,$from,$id,$filename,$fileid) = @_;
3026   my $seek = 0;
3027   my $qfileid = '';
3028   my ($head,$location);
3029   my ($response,$fexsrv,$cc);
3030   local $_;
3031
3032   $to =~ s/[,:].*//;
3033   $to = $AB{$to} if $AB{$to};
3034   $filename =~ s/([^_=:,;<>()+.\w\-])/'%'.uc(unpack("H2",$1))/ge; # urlencode
3035   if ($skey) {
3036     $head = "HEAD $proxy_prefix/fop/$to/$from/$filename??SKEY=$id HTTP/1.1";
3037   } elsif ($gkey) {
3038     $head = "HEAD $proxy_prefix/fop/$to/$from/$filename??GKEY=$id HTTP/1.1";
3039   } else {
3040     $head = "HEAD $proxy_prefix/fop/$to/$from/$filename??ID=$id HTTP/1.1";
3041   }
3042   sendheader("$server:$port",$head);
3043   $_ = <$SH>;
3044   unless (defined $_ and /\w/) {
3045     die "$0: no response from server\n";
3046   }
3047   s/\r//;
3048   print "<-- $_" if $opt_v;
3049   unless (/^HTTP.* 200/) {
3050     s:HTTP/[\d\. ]+::;
3051     $response = $_;
3052     while (<$SH>) {
3053       s/\r//;
3054       print "<-- $_" if $opt_v;
3055       $fexsrv = $_ if /^(Server: fexsrv|X-Features:)/;
3056       last if /^\s*$/;
3057     }
3058     die "$0: no fexserver at $server:$port\n" unless $fexsrv;
3059     die "$0: server response: $response";
3060   }
3061   while (<$SH>) {
3062     s/\r//;
3063     print "<-- $_" if $opt_v;
3064     last if /^$/;
3065     if (/^Content-Length:\s+(\d+)/)     { $seek = $1 }
3066     if (/^X-File-ID:\s+(.+)/)           { $qfileid = $1 }
3067     if (/^X-Features:\s+(.+)/)          { $features = $1 }
3068     if (/^X-Location:\s+(.+)/)          { $location = $1 }
3069     if (/^Connection: close/)           { $cc = $_ }
3070   }
3071
3072   # return true seek only if file is identified
3073   $seek = 0 if $qfileid and $qfileid ne $fileid;
3074
3075   if ($cc) {
3076     serverconnect($server,$port);
3077     $sid = $id;
3078   }
3079
3080   return ($seek,$location);
3081 }
3082
3083
3084 sub edit_address_book {
3085   my ($user) = @_;
3086   my $alias;
3087   my $ab = "$fexhome/ADDRESS_BOOK";
3088   my (%AB,@r);
3089   local $_;
3090
3091   die "$0: address book not available for subusers\n"      if $skey;
3092   die "$0: address book not available for group members\n" if $gkey;
3093
3094   female_mode("edit your address book?") if $opt_F;
3095
3096   %AB = query_address_book($server,$port,$user);
3097   if ($AB{ADDRESS_BOOK} !~ /\w/) {
3098     $AB{ADDRESS_BOOK} =
3099       "# Format: alias e-mail-address # Comment\n".
3100       "# Example:\n".
3101       "framstag framstag\@rus.uni-stuttgart.de\n";
3102   }
3103   open $ab,">$ab" or die "$0: cannot write to $ab - $!\n";
3104   print {$ab} $AB{ADDRESS_BOOK};
3105   close $ab;
3106
3107   system "$editor $ab";
3108   exit unless -s $ab;
3109
3110   $opt_o = $opt_A;
3111
3112   serverconnect($server,$port);
3113   query_sid($server,$port);
3114
3115   @r = formdatapost(
3116         from            => $user,
3117         to              => $user,
3118         id              => $sid,
3119         file            => $ab,
3120   );
3121
3122   unlink $ab,$ab.'~';
3123 }
3124
3125
3126 sub query_address_book {
3127   my ($server,$port,$user) = @_;
3128   my ($req,$alias,$address,$options,$comment,$cl,$ab,$b);
3129   my %AB;
3130   local $_;
3131
3132   unless ($SH) {
3133     serverconnect($server,$port);
3134     query_sid($server,$port);
3135   }
3136
3137   $req = "GET $proxy_prefix/fop/$user/$user/ADDRESS_BOOK?ID=$sid HTTP/1.1";
3138   sendheader("$server:$port",$req);
3139   $_ = <$SH>;
3140   unless (defined $_ and /\w/) {
3141     die "$0: no response from server\n";
3142   }
3143   s/\r//;
3144   print "<-- $_" if $opt_v;
3145   unless (/^HTTP.* 200/) {
3146     if (/^HTTP.* 404/) {
3147       while (<$SH>) { last if /^\r?\n/ }
3148       return;
3149     } else {
3150       # s:HTTP/[\d\. ]+::;
3151       # die "$0: server response: $_";
3152       close $SH;
3153       undef $SH;
3154       return ();
3155     }
3156   }
3157   while (<$SH>) {
3158     s/\r//;
3159     print "<-- $_" if $opt_v;
3160     last if /^$/;
3161     $cl = $1 if /^Content-Length: (\d+)/;
3162   }
3163
3164   if ($cl) {
3165     while (<$SH>) {
3166       $b += length;
3167       $ab .= $_;
3168       s/[\r\n]//g;
3169       s/^\s+//;
3170       s/\s+$//;
3171       print "<-- $_\n" if $opt_v;
3172       s/\s*#\s*(.*)//;
3173       if ($_) {
3174         $comment = $1||'';
3175         ($alias,$address,$options) = split;
3176         if ($address) {
3177           if ($options) { $options =~ s/[()]//g }
3178           else          { $options = '' }
3179           $AB{$alias} = $address;
3180           $AB{$alias}->{options} = $options||'';
3181           $AB{$alias}->{comment} = $comment||'';
3182           if ($options and $options =~ /keep=(\d+)/i) {
3183             $AB{$alias}->{keep} = $1;
3184           }
3185           if ($options and $options =~ /autodelete=(\w+)/i) {
3186             $AB{$alias}->{autodelete} = $1;
3187           }
3188         }
3189       }
3190       last if $b >= $cl;
3191     }
3192   }
3193
3194   $AB{ADDRESS_BOOK} = $ab;
3195
3196   return %AB;
3197 }
3198
3199
3200 # sets global $sid $features $timeout # ugly hack! :-}
3201 sub query_sid {
3202   my ($server,$port) = @_;
3203   my ($req,$fexsrv);
3204   local $_;
3205
3206   $sid = $id;
3207
3208   if ($port eq 443 or $proxy) {
3209     return if $features;    # early return if we know enough
3210     $req = "OPTIONS /FEX HTTP/1.1";
3211     $req = "HEAD /index.html HTTP/1.1";
3212   } else {
3213     $req = "GET /SID HTTP/1.1";
3214   }
3215
3216   sendheader("$server:$port",$req);
3217   $_ = <$SH>;
3218   unless (defined $_ and /\w/) {
3219     print "\n" if $opt_v;
3220     die "$0: no response from server\n";
3221   }
3222   s/\r//;
3223   print "<-- $_" if $opt_v;
3224
3225   if ($req =~ /OPTIONS/ and /^HTTP.* 502 /) {
3226     # (reverse) proxy error
3227     close $SH;
3228     serverconnect($server,$port);
3229     $req = "GET /SID HTTP/1.0";
3230     sendheader("$server:$port",$req);
3231     $_ = <$SH>;
3232     unless (defined $_ and /\w/) {
3233       print "\n" if $opt_v;
3234       die "$0: no response from server\n";
3235     }
3236     s/\r//;
3237     print "<-- $_" if $opt_v;
3238     while (<$SH>) {
3239       s/\r//;
3240       print "<-- $_" if $opt_v;
3241       $features = $1 if /^X-Features: (.+)/;
3242       $timeout = $1  if /^X-Timeout: (\d+)/;
3243       last if /^\n/;
3244     }
3245     close $SH;
3246     serverconnect($server,$port);
3247   } elsif (/^HTTP.* [25]0[01] /) {
3248     if (not $proxy and $port ne 443 and /^HTTP.* 201 (.+)/) {
3249       $sid = 'MD5H:'.md5_hex($id.$1);
3250     }
3251     my $cc;
3252     while (<$SH>) {
3253       s/\r//;
3254       print "<-- $_" if $opt_v;
3255       $features = $1 if /^X-Features: (.+)/;
3256       $timeout = $1  if /^X-Timeout: (\d+)/;
3257       $cc = $_       if /^Connection: close/;
3258       last           if /^\n/;
3259     }
3260     if ($cc) {
3261       serverconnect($server,$port);
3262       $sid = $id;
3263     }
3264   } elsif (/^HTTP.* 301 /) {
3265     while (<$SH>) { last if /Location/ }
3266     die "$0: cannot use $server:$port because server has a redirection to\n".$_;
3267   } else {
3268     # no SID support - perhaps transparent web proxy?
3269     while (<$SH>) {
3270       s/\r//;
3271       print "<-- $_" if $opt_v;
3272       $fexsrv = $_ if /^(Server: fexsrv|X-Features:)/;
3273       last if /^\s*$/;
3274     }
3275     die "$0: no fexserver at $server:$port\n" unless $fexsrv;
3276     serverconnect($server,$port);
3277     $sid = $id;
3278   }
3279
3280   # warn "proxy: $proxy\n";
3281   if ($proxy) {
3282     serverconnect($server,$port);
3283     $sid = $id;
3284   }
3285
3286 }
3287
3288
3289 sub xxget {
3290   my ($from,$id,$save) = @_;
3291   my $bs = 4096;
3292   my $xx = $save;
3293   my ($url,$B,$b,$t0,$t1,$cl);
3294   my ($ts,$tso);
3295   local $_;
3296
3297   $xx =~ s:.*/::;
3298   $url = "$proxy_prefix/fop/$from/$from/$xx?ID=$id";
3299
3300   sendheader("$server:$port","GET $url HTTP/1.0");
3301   http_response();
3302   while (<$SH>) {
3303     s/\r//;
3304     print "<-- $_" if $opt_v;
3305     $cl = $1 if /^Content-Length:\s(\d+)/;
3306     # $ft = $1 if /^X-File-Type:\s(.+)/;
3307     last if /^$/;
3308   }
3309
3310   die "$0: no Content-Length in server-reply\n" unless $cl;
3311
3312   open $save,">$save" or die "$0: cannot write to $save - $!\n";
3313   binmode $save;
3314
3315   $t0 = $t1 = int(time);
3316   $tso = '';
3317
3318   while ($b = read($SH,$_,$bs)) {
3319     $B += $b;
3320     print {$save} $_;
3321     if (int(time) > $t1) {
3322       $t1 = int(time);
3323       $ts = ts($B,$cl);
3324       if ($ts ne $tso) {
3325         print STDERR $ts,"\r";
3326         $tso = $ts;
3327       }
3328     }
3329     sleep 1 while ($opt_m and $B/k/(time-$t0||1) > $opt_m);
3330   }
3331
3332   print STDERR ts($B,$cl),"\n";
3333   close $save;
3334 }
3335
3336
3337 # transfer status
3338 sub ts {
3339   my ($b,$tb) = @_;
3340   return sprintf("transferred: %d MB (%d%%)",int($b/M),int($b/$tb*100));
3341 }
3342
3343
3344 sub sigpipehandler {
3345   retry("died");
3346 }
3347
3348 sub retry {
3349   my $reason = shift;
3350   local $SIG{ALRM} = sub { };
3351
3352   if (fileno $SH) {
3353     alarm(1);
3354     my @r = <$SH>;
3355     alarm(0);
3356     kill 9,$tpid if $tpid;
3357     if (@r and $opt_v) {
3358       die "\n$0: ($$) server error: @r\n";
3359     }
3360     if (@r and $r[0] =~ /^HTTP.* \d+ (.*)/) {
3361       die "\n$0: server error: $1\n";
3362     }
3363   }
3364   $timeout *= 2;
3365   warn "\n$0: connection to $server $reason\n";
3366   warn "retrying after $timeout seconds...\n";
3367   sleep $timeout;
3368   if ($windoof) { exec $^X,$0,@_ARGV }
3369   else          { exec $_0,@_ARGV }
3370   die $!;
3371 }
3372
3373
3374 sub checkrecipient {
3375   my ($from,$to) = @_;
3376   my @r;
3377   local $_;
3378
3379   @r = formdatapost(
3380         from    => $from,
3381         to      => $to,
3382         id      => $sid,
3383         command => 'CHECKRECIPIENT',
3384   );
3385
3386   $_ = shift @r or die "$0: no reply from server\n";
3387
3388   if (/ 2\d\d /) {
3389     return if $to eq 'nettest';
3390     foreach (@r) {
3391       last if /^$/;
3392       if (s/X-(Recipient: .+)/$1\n/) {
3393         s/autodelete=\w+/autodelete=$opt_D/ if $opt_D;
3394         s/keep=\d+/keep=$opt_k/             if $opt_k;
3395         print;
3396         $frecipient ||= (split)[1];
3397       }
3398     }
3399   } else {
3400     http_response($_,@r);
3401   }
3402 }
3403
3404
3405 # get ID data from ID file
3406 sub get_id {
3407   my $idf = shift;
3408
3409   $fexcgi = getline($idf) || die "$0: no FEX-URL in $idf\n";
3410   $from   = getline($idf) || die "$0: no FROM in $idf\n";
3411   $id     = getline($idf) || die "$0: no ID in $idf\n";
3412   if ($fexcgi =~ s/!([\w.-]+:\d+)(:(\d+))?//) {
3413     $proxy = $1;
3414     $chunksize = $3 || 0;
3415   }
3416   unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
3417     die "$0: illegal FEX-URL \"$fexcgi\" in $idf\n";
3418   }
3419   unless ($from =~ /^[_:=\w\-\.\/\@\%\+]+$/) {
3420     die "$0: illegal FROM \"$from\" in $idf\n";
3421   }
3422   $fexcgi =~ s:/+$::;
3423 }
3424
3425
3426 # for windows
3427 sub inquire {
3428   my ($file,$to);
3429   for (;;) {
3430     print "file to send: ";
3431     chomp($file = <STDIN>);
3432     $file =~ s/^\"//;
3433     $file =~ s/\"$//;
3434     last if -e $file;
3435     warn "$file does not exist\n";
3436   }
3437   print "recipient (e-mail address): ";
3438   chomp($to = <STDIN>);
3439   die $usage unless $to;
3440   unless ($opt_n) {
3441     print "comment: ";
3442     chomp($opt_C = <STDIN>);
3443   }
3444   @ARGV = ($file,$to);
3445 }
3446
3447
3448 sub shelldo {
3449   if (system(@_) < 0) { die "failed: @_\n" }
3450 }
3451
3452
3453 # emulate seek on a pipe
3454 sub readahead {
3455   my $fh = shift; # filehandle
3456   my $ba = shift; # bytes ahead
3457   my $bs = 2**16;
3458   my $s = 0;
3459   my $n;
3460   local $_;
3461
3462   while ($s < $ba) {
3463     $n = $ba-$s;
3464     $n = $bs if $n > $bs;
3465     $s += read $fh,$_,$n;
3466   }
3467 }
3468
3469
3470 sub fileid {
3471   my $file = shift;
3472   my @s = stat($file);
3473
3474   if (@s) {
3475     return md5_hex($file.$s[0].$s[1].$s[7].$s[9]);
3476   } else {
3477     warn "$0: $file - $!\n";
3478     return int(time);
3479   }
3480 }
3481
3482
3483 sub get_mutt_alias {
3484   my $to = shift;
3485   my $ma = $HOME.'/.mutt/aliases';
3486   my ($alias,$options);
3487   local $_;
3488
3489   $to =~ s/(:.+)// and $options = $1;
3490   open $ma,$ma or return $to;
3491   while (<$ma>) {
3492     if (/^alias \Q$to\E\s/i) {
3493       chomp;
3494       s/\s*#.*//;
3495       s/\(.*?\)//;
3496       s/\s+$//;
3497       s/.*\s+//;
3498       s/[<>]//g;
3499       if (/,/) {
3500         warn "$0: ignoring mutt multi-alias $to = $_\n";
3501         last;
3502       }
3503       if (/@/) {
3504         $alias = $_;
3505         warn "$0: found mutt alias $to = $alias\n";
3506         $alias .= $options if $options;
3507         last;
3508       }
3509     }
3510   }
3511   close $ma;
3512   $to = "$to:$options" if $options;
3513   return ($alias||$to);
3514 }
3515
3516
3517 # collect (hashed) file meta data
3518 sub fmd {
3519   my @files = @_;
3520   my ($file,$dir);
3521   my $fmd = '';
3522
3523   foreach $file (@files) {
3524     if (not -l $file and -d $file) {
3525       $dir = $file;
3526       if (opendir $dir,$dir) {
3527         while (defined ($file = readdir($dir))) {
3528           next if $file eq '..';
3529           if ($file eq '.') {
3530             $fmd .= fileid($dir);
3531           } else {
3532             $fmd .= fmd("$dir/$file");
3533           }
3534         }
3535         closedir $dir;
3536       }
3537     } else {
3538       $fmd .= fileid($file);
3539     }
3540   }
3541
3542   return $fmd;
3543 }
3544
3545
3546 # from MIME::Base64::Perl
3547 sub decode_b64 {
3548   local $_ = shift;
3549   my $uu = '';
3550   my ($i,$l);
3551
3552   tr|A-Za-z0-9+=/||cd;
3553   s/=+$//;
3554   tr|A-Za-z0-9+/| -_|;
3555   return "" unless length;
3556
3557   $l = (length)-60;
3558   for ($i = 0; $i <= $l; $i += 60) {
3559     $uu .= "M" . substr($_,$i,60);
3560   }
3561   $_ = substr($_,$i);
3562   if (length) {
3563     $uu .= chr(32+(length)*3/4) . $_;
3564   }
3565   return unpack("u",$uu);
3566 }
3567
3568
3569 sub female_mode {
3570   local $_;
3571   if (open my $tty,'/dev/tty') {
3572     print "@_\n";
3573     print "  [y] yes\n",
3574           "  [n] no\n",
3575           "  [p] perhaps - don't know\n",
3576           "your choice: ";
3577     $_ = <$tty> || '';
3578     close $tty;
3579     if (/^y/i) { return }
3580     if (/^n/i) { exit }
3581     if (/^p/i) { int(rand(2)) ? return : exit }
3582     female_mode(@_);
3583   }
3584 }
3585
3586
3587 sub http_response {
3588   local $_ = shift || <$SH>;
3589   my @r = @_;
3590   my $error;
3591
3592   $_ = <$SH> unless $_;
3593   unless (defined $_ and /\w/) {
3594     die "$0: no response from server\n";
3595   }
3596   s/\r?\n//;
3597   print "<-- $_\n" if $opt_v;
3598   # CGI fatalsToBrowser
3599   if (/^HTTP.* 500/) {
3600     @r = <$SH> unless @r;
3601     @r = ()    unless @r;
3602     die "$0: server error: $_\n@r\n";
3603   }
3604   unless (/^HTTP.* 200/) {
3605     $error = $_;
3606     $error =~ s/HTTP.[\s\d.]+//;
3607     @r = <$SH> unless @r;
3608     @r = ()    unless @r;
3609     foreach (@r) {
3610       chomp;
3611       $error .= "\n".$_ if /^Location/;
3612       print "<-- $_\n" if $opt_v;
3613     }
3614     die "$0: server error: $error\n";
3615   }
3616
3617   return $_;
3618 }
3619
3620
3621 sub ws {
3622   local $_ = shift;
3623   return split;
3624 }
3625
3626
3627 sub update {
3628   my $cfb = '### common functions ###';
3629   my $cfc;
3630
3631   local $/;
3632
3633   open $0,$0 or die "cannot read $0 - $!\n";
3634   $cfc = <$0>;
3635   close $0;
3636   $cfc =~ s/.*\n$cfb\n//s;
3637
3638   foreach my $p (qw'fexget sexsend') {
3639     open $p,$p or die "cannot read $p - $!\n";
3640     $_ = <$p>;
3641     close $p;
3642     s/\n$cfb.*/\n$cfb\n$cfc/s;
3643     system "vv -s $p";
3644     open $p,'>',$p or die "cannot write $p - $!\n";
3645     print {$p} $_;
3646     close $p;
3647   }
3648
3649   exec "l fexsend fexget sexsend";
3650   exit;
3651 }
3652
3653 ### common functions ###
3654
3655
3656 sub mtime {
3657   my @d = localtime((stat shift)[9]);
3658   return sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
3659 }
3660
3661
3662 sub urldecode {
3663   local $_ = shift;
3664   s/\%([a-f\d]{2})/chr(hex($1))/ige;
3665   return $_;
3666 }
3667
3668
3669 sub get_ssl_env {
3670   # set SSL/TLS options
3671   $SSL{SSL_verify_mode} = $ENV{SSLVERIFY} if defined($ENV{SSLVERIFY});
3672   foreach my $opt (qw(
3673     SSL_version
3674     SSL_cipher_list
3675     SSL_verify_mode
3676     SSL_ca_path
3677     SSL_ca_file)
3678   ) {
3679     my $env = uc($opt);
3680     $env =~ s/_//g;
3681     $SSL{$opt} = $ENV{$env} if defined($ENV{$env});
3682   }
3683
3684   if ($SSL{SSL_verify_mode}) {
3685     &search_ca;
3686     unless ($SSL{SSL_ca_path} or $SSL{SSL_ca_file}) {
3687       die "$0: \$SSLVERIFYMODE, but not valid \$SSLCAPATH or \$SSLCAFILE\n";
3688     }
3689   } elsif (defined($SSL{SSL_verify_mode})) {
3690     # user has set SSLVERIFY=0 !
3691   } else {
3692     &search_ca;
3693     $SSL{SSL_verify_mode} = 1 if $SSL{SSL_ca_path} or $SSL{SSL_ca_file};
3694   }
3695 }
3696
3697 sub search_ca {
3698   local $_;
3699   return if $SSL{SSL_ca_file} or $SSL{SSL_ca_path};
3700   foreach (qw(/etc/ssl/certs/ca-certificates.crt)) {
3701     if (-f) {
3702       $SSL{SSL_ca_file} = $_;
3703       return;
3704     }
3705   }
3706   foreach (qw(/etc/ssl/certs /etc/pki/tls/certs)) {
3707     if (-f) {
3708       $SSL{SSL_ca_path} = $_;
3709       return;
3710     }
3711   }
3712 }
3713
3714
3715 sub serverconnect {
3716   my ($server,$port) = @_;
3717   my $connect = "CONNECT $server:$port HTTP/1.1";
3718   local $_;
3719
3720   if ($proxy) {
3721     tcpconnect(split(':',$proxy));
3722     if ($https) {
3723       printf "--> %s\n",$connect if $opt_v;
3724       nvtsend($connect,"");
3725       $_ = <$SH>;
3726       s/\r//;
3727       printf "<-- $_"if $opt_v;
3728       unless (/^HTTP.1.. 200/) {
3729         die "$0: proxy error : $_";
3730       }
3731       &enable_ssl;
3732       $SH = IO::Socket::SSL->start_SSL($SH,%SSL);
3733     }
3734   } else {
3735     tcpconnect($server,$port);
3736   }
3737 #  if ($https and $opt_v) {
3738 #    printf "%s\n",$SH->get_cipher();
3739 #  }
3740 }
3741
3742
3743 # set up tcp/ip connection
3744 sub tcpconnect {
3745   my ($server,$port) = @_;
3746
3747   if ($SH) {
3748     close $SH;
3749     undef $SH;
3750   }
3751
3752   if ($https) {
3753     # eval "use IO::Socket::SSL qw(debug3)";
3754     &enable_ssl;
3755     $SH = IO::Socket::SSL->new(
3756       PeerAddr => $server,
3757       PeerPort => $port,
3758       Proto    => 'tcp',
3759       %SSL
3760     );
3761   } else {
3762     $SH = IO::Socket::INET->new(
3763       PeerAddr => $server,
3764       PeerPort => $port,
3765       Proto    => 'tcp',
3766     );
3767   }
3768
3769   if ($SH) {
3770     autoflush $SH 1;
3771     binmode $SH;
3772   } else {
3773     die "$0: cannot connect $server:$port - $@\n";
3774   }
3775
3776   print "TCPCONNECT to $server:$port\n" if $opt_v;
3777 }
3778
3779
3780 sub enable_ssl {
3781   eval "use IO::Socket::SSL";
3782   die "$0: cannot load IO::Socket::SSL\n" if $@;
3783   eval '$SSL{SSL_verify_mode} = 0 if Net::SSLeay::SSLeay() <= 9470143';
3784   if ($opt_v) {
3785     foreach my $v (keys %SSL) {
3786       printf "%s => %s\n",$v,$SSL{$v};
3787     }
3788   }
3789 }
3790
3791
3792 sub sendheader {
3793   my $sp = shift;
3794   my @head = @_;
3795   my $head;
3796
3797   push @head,"Host: $sp";
3798   push @head,"User-Agent: $useragent";
3799
3800   foreach $head (@head) {
3801     chomp $head;
3802     print "--> $head\n" if $opt_v;
3803     print {$SH} $head,"\r\n";
3804   }
3805   print "-->\n" if $opt_v;
3806   print {$SH} "\r\n";
3807 }
3808
3809
3810 sub nvtsend {
3811   local $SIG{PIPE} = sub { $sigpipe = "@_" };
3812
3813   $sigpipe = '';
3814
3815   die "$0: internal error: no active network handle\n" unless $SH;
3816   die "$0: remote host has closed the link\n" unless $SH->connected;
3817
3818   foreach my $line (@_) {
3819     print {$SH} $line,"\r\n";
3820     if ($sigpipe) {
3821       undef $SH;
3822       return 0;
3823     }
3824   }
3825
3826   return 1;
3827 }
3828
3829
3830 sub quote {
3831   local $_ = shift;
3832   s/([^\w\@\/%^,.=+_:+-])/\\$1/g;
3833   return $_;
3834 }
3835
3836
3837 sub debug {
3838   print "## DEBUG: @_\n" if $DEBUG;
3839 }
3840
3841
3842 # from MIME::Base64::Perl
3843 sub encode_b64 {
3844   my $res = "";
3845   my $eol = "\n";
3846   my $padding;
3847
3848   pos($_[0]) = 0;
3849   $res = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
3850   $res =~ tr|` -_|AA-Za-z0-9+/|;
3851   $padding = (3-length($_[0])%3)%3;
3852   $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
3853   return $res;
3854 }