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