bin/fexsend

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