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