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