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