htdocs/download/fexget

   1 #!/usr/bin/perl -w
   2
   3 # CLI client for the FEX service for retrieving files
   4 #
   5 # see also: fexsend
   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 Config;
  14 use POSIX;
  15 use Encode;
  16 use Cwd 'abs_path';
  17 use Getopt::Std;
  18 use File::Basename;
  19 use Socket;
  20 use IO::Handle;
  21 use IO::Socket::INET;
  22 use Time::HiRes 'time';
  23 use constant k => 2**10;
  24 use constant M => 2**20;
  25
  26 eval 'use Net::INET6Glue::INET_is_INET6';
  27
  28 $| = 1;
  29
  30 our $SH;
  31 our ($fexhome,$idf,$tmpdir,$windoof,$useragent);
  32 our ($xv,%autoview);
  33 our $bs = 2**16; # blocksize for tcp-reading and writing file
  34 our $version = 20160919;
  35 our $CTYPE = 'ISO-8859-1';
  36 our $fexsend = $ENV{FEXSEND} || 'fexsend';
  37 our $DEBUG = $ENV{DEBUG};
  38 our $_0 = $0;
  39
  40 my %SSL = (SSL_version => 'TLSv1');
  41 my $sigpipe;
  42
  43 # inquire default character set
  44 # cannot use "use I18N::Langinfo" because of no windows support!
  45 eval {
  46   local $^W = 0;
  47   require I18N::Langinfo;
  48   I18N::Langinfo->import(qw'langinfo CODESET');
  49   $CTYPE = langinfo(CODESET());
  50 };
  51
  52 if ($Config{osname} =~ /^mswin/i) {
  53   $windoof = $Config{osname};
  54   $ENV{HOME} = $ENV{USERPROFILE};
  55   $fexhome = $ENV{FEXHOME} || $ENV{HOME}.'/fex';
  56   $tmpdir = $ENV{FEXTMP} || $ENV{TMP} || "$fexhome/tmp";
  57   $idf = "$fexhome/id";
  58   $useragent = sprintf("fexget-$version (%s %s)",
  59                        $Config{osname},$Config{archname});
  60   $SSL{SSL_verify_mode} = 0;
  61   chdir $ENV{USERPROFILE}.'\Desktop';
  62   # open XX,'>XXXXXX';close XX;
  63 } elsif ($Config{osname} =~ /^darwin/i or $ENV{MACOS}) {
  64   $0 =~ s:(.*)/:: and $ENV{PATH} .= ":$1";
  65   $fexhome = $ENV{FEXHOME} || $ENV{HOME}.'/.fex';
  66   $tmpdir = $ENV{FEXTMP} || $ENV{TMPDIR} || "$fexhome/tmp";
  67   $idf = "$fexhome/id";
  68   $_ = `sw_vers -productVersion 2>/dev/null`||'';
  69   chomp;
  70   $useragent = "fexget-$version (MacOS $_)";
  71 } else {
  72   $0 =~ s:(.*)/:: and $ENV{PATH} .= ":$1";
  73   $fexhome = $ENV{FEXHOME} || $ENV{HOME}.'/.fex';
  74   $tmpdir = $ENV{FEXTMP} || "$fexhome/tmp";
  75   $idf = "$fexhome/id";
  76   $_ = `(lsb_release -d||uname -a)2>/dev/null`||'';
  77   chomp;
  78   s/^Description:\s+//;
  79   $useragent = "fexget-$version ($_)";
  80 }
  81
  82 if (-f ($_ = '/etc/fex/config.pl')) {
  83   eval { require } or warn $@;
  84 }
  85
  86 my $usage = <<EOD;
  87 usage: $0 [-v] [-m limit] [-s filename] [-o] [-k] [-X] [-P proxy:port] F*EX-URL(s)
  88    or: $0 [-v] -d F*EX-URL(s)
  89    or: $0 [-v] -f F*EX-URL(s) e-mail-address
  90    or: $0 [-v] -a
  91    or: $0 -l [-i tag]
  92    or: $0 -H
  93    or: $0 -V
  94 options: -v verbose mode
  95          -m limit kB/s
  96          -s save to filename (-s- means: write to STDOUT/pipe)
  97          -o overwrite existing file
  98          -k keep on server after download
  99          -X do not extract archive files or autoview file
 100          -d delete without download
 101          -f forward a file to another recipient
 102          -a get all files (implies -X)
 103          -l list files on server
 104          -i tag alternate server/account, see: $fexsend -h
 105          -P use Proxy for connection to the F*EX server
 106          -H show hints and examples
 107          -V show version and ask for upgrade
 108 argument: F*EX-URL may be file number (see: $0 -l)
 109 EOD
 110
 111 my $hints = <<'EOD';
 112 When you download a file with extension .jpg .gif .png or .tif an image viewer
 113 will be started. This can be xv or xdg-open.
 114 In $HOME/.fex/config.pl you can set your prefered autoview applications:
 115
 116 %autoview = (
 117   '\.(gif|jpg|png|tiff?)' => 'my_prefered_image_viewer',
 118   '\.(avi|mp4|mov)'       => 'vlc -f',
 119   '\.pdf'                 => 'evince',
 120 );
 121
 122 For HTTPS you can set the environment variables:
 123 SSLVERIFY=1                 # activate server identity verification
 124 SSLVERSION=TLSv1            # this is the default
 125 SSLCAPATH=/etc/ssl/certs    # path to trusted (root) certificates
 126 SSLCAFILE=/etc/ssl/cert.pem # file with trusted (root) certificates
 127 SSLCIPHERLIST=HIGH:!3DES    # see http://www.openssl.org/docs/apps/ciphers.html
 128
 129 You can set these environment variables also in $HOME/.fex/config.pl, as well as
 130 the $opt_* variables, e.g.:
 131
 132 $ENV{SSLVERSION} = 'TLSv1';
 133 ${'opt_+'} = 1;
 134 $opt_m = 200;
 135 EOD
 136
 137 if ($windoof and not @ARGV and not $ENV{PROMPT}) {
 138   # restart with cmd.exe to have mouse cut+paste
 139   my $cmd = "cmd /k \"$0\"";
 140   # print "$cmd\n";
 141   exec $cmd;
 142   exit;
 143 }
 144
 145 my $atype = '\.(tgz|tar|zip|7z)$';
 146 my $proxy = '';
 147 my $proxy_prefix = '';
 148 my $chunksize;
 149
 150 our ($opt_h,$opt_v,$opt_l,$opt_d,$opt_m,$opt_z,$opt_K,$opt_o,$opt_a);
 151 our ($opt_s,$opt_k,$opt_i,$opt_V,$opt_X,$opt_f,$opt_P,$opt_L,$opt_H);
 152 $opt_m = $opt_h = $opt_v = $opt_l = $opt_d = $opt_K = $opt_o = $opt_a = 0;
 153 $opt_V = $opt_X = $opt_f = $opt_L = $opt_H = 0;
 154 ${'opt_+'} = 0;
 155 $opt_s = $opt_k = $opt_i = $opt_P = '';
 156 $_ = "$fexhome/config.pl"; require if -f;
 157 getopts('hvVHlLdkzoaXVf+m:s:i:K:P:') or die $usage;
 158 $opt_k = '?KEEP' if $opt_k;
 159
 160 if ($opt_m =~ /(\d+)/) {
 161   $opt_m = $1
 162 } else {
 163   $opt_m = 0
 164 }
 165
 166 if ($opt_V) {
 167   print "Version: $version\n";
 168   unless (@ARGV) {
 169     print "Upgrade fexget? ";
 170     $_ = <STDIN>||'';
 171     if (/^y/i) {
 172       my $new = `wget -nv -O- http://fex.belwue.de/download/fexget`;
 173       my $newversion = $1 if $new =~ /version = (\d+)/;
 174       if ($new !~ /upgrade fexget/ or not $newversion) {
 175         die "$0: bad update\n";
 176       }
 177       if ($newversion <= $version) {
 178         die "$0: no newer version\n";
 179       }
 180       $_0 = abs_path($_0);
 181       system qw'rsync -a',$_0,$_0.'_old';
 182       exit $? if $?;
 183       open $_0,'>',$_0 or die "$0: cannot write $_0. - $!\n";
 184       print {$_0} $new;
 185       close $_0;
 186       exec $_0,qw'-V .';
 187     }
 188   }
 189   exit;
 190   exit if "@ARGV" eq '.';
 191 }
 192
 193 die $usage                  if $opt_h;
 194 if ($opt_H) {
 195   print $hints;
 196   exit;
 197 }
 198
 199 &get_ssl_env;
 200
 201 my $ffl = "$tmpdir/fexget";             # F*EX files list (cache)
 202
 203 my @rcamel = (
 204 '\e[A
 205  (_*p _  _
 206    \\\\/ \/ \\
 207     \  __  )=*
 208     //\\\\//\\\\
 209 ',
 210 "\e[A     \\\\/\\\\/ \n",
 211 "\e[A    //\\\\//\\\\\n"
 212 );
 213
 214 # get fexlog
 215 if ($opt_z) {
 216   my $cmd = "$fexsend -Z";
 217   $cmd .= " -i $opt_i" if $opt_i;
 218   warn "$cmd\n" if $opt_v;
 219   exec $cmd;
 220   die "$0: cannot run $cmd : $!\n";
 221 }
 222
 223 if ($opt_l) {
 224   &list;
 225   exit;
 226 }
 227
 228 if ($opt_L) {
 229   my $cmd = "$fexsend -L";
 230   $cmd .= " -i $opt_i" if $opt_i;
 231   warn "$cmd\n" if $opt_v;
 232   exec $cmd;
 233   die "$0: cannot run $cmd : $!\n";
 234 }
 235
 236 if ($opt_P) {
 237   if ($opt_P =~ /^([\w.-]+:\d+)(:(\d+))?/) {
 238     $proxy = $1;
 239     $chunksize = $3 || 0;
 240   } else {
 241     die "$0: proxy must be: SERVER:PORT\n";
 242   }
 243 }
 244
 245 if ($opt_a) {
 246   $opt_X = $opt_a;
 247   die $usage if @ARGV;
 248   &list;
 249   print "\n";
 250   if (open $ffl,$ffl) {
 251     while (<$ffl>) {
 252       push @ARGV,$1 if /^\s+(\d+)/;
 253     }
 254     close $ffl;
 255   }
 256 } else {
 257   unless (@ARGV) {
 258     if ($windoof) {
 259       my $url;
 260       for (;;) {
 261         print "download-URL: ";
 262         chomp($url = <STDIN>);
 263         if ($url =~ /^http/) {
 264           @ARGV = ($url);
 265           last;
 266         }
 267       }
 268     } else {
 269       die $usage;
 270     }
 271   }
 272 }
 273
 274 my ($file,%files,$download,$server,$port,$fop,$https);
 275
 276 if ($opt_f) {
 277   unless ($ENV{FEXID} or -f $ENV{HOME}.'/.fex/id') {
 278     die "$0: no local FEXID\n";
 279   }
 280   $opt_f = pop(@ARGV);
 281   if ($opt_f =~ /^\d+$|^https?:/) {
 282     die "$0: $opt_f is not an e-mail address\n";
 283   }
 284 }
 285
 286 URL: foreach my $url (@ARGV) {
 287
 288   # do not overrun server
 289   sleep 1 if $fop;
 290
 291   if ($url !~ /^http/) {
 292     unless (%files) {
 293       open $ffl,$ffl or die "$0: no $ffl, use first: $0 -l\n";
 294       my $from = '';
 295       while (<$ffl>) {
 296         if (/^from (.+) :$/) {
 297           $from = $1;
 298         } elsif (/^\s*(\d+)\)\s+\d+ MB.* (http\S+)/) {
 299           push @{$files{all}},$2;
 300           push @{$files{$from}},$2;
 301         }
 302       }
 303       close $ffl;
 304     }
 305
 306     if ($url =~ /^(\d+)$/) {
 307       $url = ${files{all}}[$1-1] or die "$0: unknown file number\n";
 308     }
 309   }
 310
 311   if ($url =~ m{^http(s?)://([\w\.\-]+)(:(\d+))?(/.*fop/\S+)}) {
 312     $https  = $1;
 313     $server = $2;
 314     $port   = $4 || ($1?443:80);
 315     $fop    = $5;
 316   } else {
 317     die "$0: unknown F*EX URL $url\n";
 318   }
 319
 320   if ($proxy) {
 321     if    ($port == 80)   { $proxy_prefix = "http://$server" }
 322     elsif ($port == 443)  { $proxy_prefix = "" }
 323     else                  { $proxy_prefix = "http://$server:$port" }
 324   }
 325
 326   serverconnect($server,$port);
 327
 328   if ($opt_f) {
 329     forward($url);
 330     next;
 331   }
 332
 333   if ($opt_d) {
 334     my @r = del($url);
 335     $_ = shift @r;
 336     if (/^HTTP.* 200/) {
 337       ($file) = grep { $_ = $1 if /^X-File:\s+(.+)/ } @r;
 338       $file = $url unless $file;
 339       $file =~ s:.*/::;
 340       printf "%s deleted\n",locale(decode_utf8(urldecode($file)));
 341     } else {
 342       s:HTTP/[\d\. ]+::;
 343       die "$0: server response: $_";
 344     }
 345     next;
 346   }
 347
 348   if ($opt_K) {
 349     my @r = keep($url);
 350     $_ = shift @r;
 351     if (/^HTTP.* 200/) {
 352       $file = $url;
 353       $file =~ s:.*/::;
 354       print "$file kept\n";
 355     } else {
 356       s:HTTP/[\d\. ]+::;
 357       die "$0: server response: $_";
 358     }
 359     next;
 360   }
 361
 362   $download = download($server,$port,$fop);
 363   exit if $opt_s eq '-';
 364   unlink $download unless -s $download;
 365   exit 2 unless -f $download;
 366
 367   if ($windoof) {
 368     print "READY\n";
 369     exit;
 370   }
 371
 372   if (not $opt_X and $download =~ /\.gpg$/) {
 373     if (-t) {
 374       print "decrypt \"$download\"? ";
 375       $_ = <STDIN>||'y';
 376       unless (/^[y\n]/i) {
 377         print "keeping \"$download\"\n";
 378         exit;
 379       }
 380     }
 381     if (system('gpg',$download) == 0) {
 382       unlink $download;
 383       $download =~ s/\.gpg$//;
 384     }
 385   }
 386
 387   unless ($opt_X) {
 388
 389     foreach my $a (keys %autoview) {
 390       if ($download =~ /$a$/i and $autoview{$a}) {
 391         printf "run \"%s %s\" [Yn] ? ",$autoview{$a},basename($download);
 392         $_ = <STDIN>||'';
 393         system sprintf("%s %s",$autoview{$a},quote($download)) if /^y|^$/i;
 394         next URL;
 395       }
 396     }
 397
 398     if ($ENV{DISPLAY} and $download =~ /\.(gif|jpg|png|tiff?)$/i) {
 399       # see also mimeopen and xdg-mime
 400       # http://unix.stackexchange.com/questions/144047/how-does-xdg-open-do-its-work
 401       if (my $xv = $xv || pathsearch('xv') || pathsearch('xdg-open')) {
 402         printf "run \"%s %s\" [Yn] ? ",basename($xv),basename($download);
 403         $_ = <STDIN>||'';
 404         system $xv,$download if /^y|^$/i;
 405         next URL;
 406       }
 407     }
 408
 409     if ($download =~ /$atype/) {
 410       if    ($download =~ /\.(tgz|tar.gz)$/) { extract('tar tvzf','tar xvzf') }
 411       elsif ($download =~ /\.tar$/)          { extract('tar tvf','tar xvf') }
 412       elsif ($download =~ /\.zip$/i)         { extract('unzip -l','unzip') }
 413       elsif ($download =~ /\.7z$/i)          { extract('7z l','7z x') }
 414       else { die "$0: unknown archive \"$download\"\n" }
 415       if ($? == 0) {
 416         unlink $download;
 417       } else {
 418         die "$0: keeping \"$download\"\n";
 419       }
 420     }
 421   }
 422
 423 }
 424
 425 exit;
 426
 427 sub extract {
 428   my $l = shift;
 429   my $x = shift;
 430   my $d = $download;
 431   my $xd = '';
 432   local $_;
 433
 434   if (-t and not $windoof) {
 435     print "Files in archive:\n";
 436     system(split(' ',$l),$download);
 437     $d =~ s:.*/:./:;
 438     $d =~ s/\.[^.]+$//;
 439     $d =~ s:/*$:/:;
 440     for (;;) {
 441       $xd = inquire("extract to directory (Ctrl-C to keep archive): ",$d);
 442       last if $xd =~ s:^(\./*)*!?$::;
 443       if ($xd eq '-') {
 444         print "keeping $download\n";
 445         exit;
 446       }
 447       if ($xd !~ s/!$//) {
 448         if (-d $xd) {
 449           print "directory $xd does already exist, add \"!\" to overwrite\n";
 450           redo;
 451         }
 452         unless (mkdir $xd) {
 453           print "cannot mkdir $xd - $!\n";
 454           redo;
 455         }
 456       }
 457       unless (chdir $xd) {
 458         print "cannot chdir $xd - $!\n";
 459         redo;
 460       }
 461       last;
 462     }
 463   }
 464   print "extracting to $xd :\n" if $xd;
 465   system(split(' ',$x),$download);
 466   print "extracted to $xd\n" if $xd;
 467 }
 468
 469 sub del {
 470   my $url = shift;
 471   my ($server,$port);
 472   my $del;
 473   my @r;
 474
 475   if ($url =~ m{^http(s?)://([\w\.\-]+)(:(\d+))?(/fop/.+)}) {
 476     $server = $2;
 477     $port   = $4 || ($1?443:80);
 478     $del    = $5.'?DELETE';
 479   } else {
 480     die "$0: unknown F*EX URL $url\n";
 481   }
 482
 483   sendheader("$server:$port","GET $del HTTP/1.1","User-Agent: $useragent");
 484   while (<$SH>) {
 485     s/\r//;
 486     last if /^\n/; # ignore HTML output
 487     warn "<-- $_" if $opt_v;
 488     push @r,$_;
 489   }
 490   die "$0: no response from fex server $server\n" unless @r;
 491   return @r;
 492 }
 493
 494
 495 sub forward {
 496   my $url = shift;
 497   my ($server,$port);
 498   my ($uri,$dkey,$list,$cmd,$n,$copy);
 499   my @r;
 500
 501   if ($url =~ m{^http(s?)://([\w\.\-]+)(:(\d+))?(/fop/.+)}) {
 502     $server = $2;
 503     $port   = $4 || ($1?443:80);
 504     $uri    = $5;
 505   } else {
 506     die "$0: unknown F*EX URL $url\n";
 507   }
 508
 509   sendheader(
 510     "$server:$port",
 511     "GET $uri?COPY HTTP/1.1",
 512     "User-Agent: $useragent",
 513   );
 514
 515   $_ = <$SH>;
 516   die "$0: no reply from fex server $server\n" unless $_;
 517   warn "<-- $_" if $opt_v;
 518
 519   if (/^HTTP.*already exists/) {
 520     if ($uri =~ m:/fop/(\w+)/:) {
 521       $dkey = $1;
 522     }
 523   } elsif (/^HTTP.*200/) {
 524     # ok!
 525   } else {
 526     s/^HTTP.... \d+ //;
 527     die "$0: $_";
 528   }
 529
 530   while (<$SH>) {
 531     s/\r//;
 532     last if /^\n/; # ignore HTML output
 533     $dkey = $1 if /^Location:.*\/(\w+)\/.+/;
 534     warn "<-- $_" if $opt_v;
 535   }
 536
 537   print "fexsend -l\n" if $opt_v;
 538   system 'fexsend -l >/dev/null 2>&1';
 539   $list = $ENV{HOME}.'/.fex/tmp/fexlist';
 540   open $list,$list or die "$0: cannot open $list - $!\n";
 541   while (<$list>) {
 542     if (/^\s+(\d+)\) (\w+)/ and $2 eq $dkey) {
 543       $n = $1;
 544       $cmd = "fexsend -b $n $opt_f";
 545       print "$cmd\n" if $opt_v;
 546       system $cmd;
 547       last;
 548     }
 549   }
 550   close $list;
 551
 552   if ($n) {
 553     $cmd = "fexsend -d $n >/dev/null 2>&1";
 554     print "$cmd\n" if $opt_v;
 555     system $cmd;
 556   } else {
 557     warn "$0: forwarding failed\n";
 558   }
 559 }
 560
 561
 562 sub keep {
 563   my $url = shift;
 564   my ($server,$port);
 565   my $keep;
 566   my (@hh,@r);
 567
 568   if ($url =~ m{^http(s?)://([\w\.\-]+)(:(\d+))?(/fop/.+)}) {
 569     $server = $2;
 570     $port   = $4 || ($1?443:80);
 571     $keep    = "$5?KEEP=$opt_K";
 572   } else {
 573     die "$0: unknown F*EX URL $url\n";
 574   }
 575
 576   push @hh,"GET $keep HTTP/1.1",
 577            "Host: $server:$port",
 578            "User-Agent: $useragent",
 579            "";
 580
 581   foreach (@hh) {
 582     warn $_,"\n" if $opt_v;
 583     print $SH $_,"\r\n";
 584   }
 585   while (<$SH>) {
 586     s/\r//;
 587     last if /^\n/;
 588     push @r,$_;
 589   }
 590   die "$0: no response from fex server $server\n" unless @r;
 591   grep { warn "\t$_" } @r if $opt_v;
 592   return @r;
 593 }
 594
 595
 596 sub download {
 597   my ($server,$port,$fop,$nocheck) = @_;
 598   my ($file,$download,$ssl,$pipe,$filesize,$checkstorage,$dkey);
 599   my (@hh,@r);
 600   my ($t0,$t1,$t2,$tt,$tm,$ts,$kBs,$b,$bt,$tb,$B,$buf);
 601   my $length = 0;
 602   my $seek = 0;
 603   my $tc = 0;
 604   local $_;
 605   local *X;
 606
 607   if ($opt_s) {
 608     $file = $opt_s;
 609     if ($opt_s eq '-') {
 610       $pipe = $download = $opt_s;
 611     } elsif (-p $opt_s or -c $opt_s) {
 612       $download = $opt_s;
 613       $nocheck = 'pipe or character device';
 614     } else {
 615       $download = $file.'.tmp';
 616       $seek = -s $download || 0;
 617     }
 618   } else {
 619     # ask server for real file name
 620     sendheader(
 621       "$server:$port",
 622       "HEAD $proxy_prefix$fop HTTP/1.1",
 623       "User-Agent: $useragent"
 624     );
 625     my $reply = $_ = <$SH>;
 626     unless (defined $_ and /\w/) {
 627       die "$0: no response from server\n";
 628     }
 629     warn "<-- $_" if $opt_v;
 630     unless (/^HTTP\/[\d.]+ 200/) {
 631       s:HTTP/[\d. ]+::;
 632       die "$0: server response: $_";
 633     }
 634     while (<$SH>) {
 635       s/\r//;
 636       warn "<-- $_" if $opt_v;
 637       last if /^\r?\n/;
 638       if (/^Content-Disposition: attachment; filename="(.+)"/i) {
 639         $file = locale(decode_utf8($1));
 640           $file =~ s:.*/::;
 641       }
 642     }
 643     unless ($file) {
 644       $file = $fop;
 645       $file =~ s:.*/::;
 646     }
 647     $download = $file.'.tmp';
 648     $seek = -s $download || 0;
 649   }
 650
 651   $fop =~ m:/fop/(\w+)/: and $dkey=$1 or $dkey='';
 652
 653   push @hh,"GET $proxy_prefix$fop$opt_k HTTP/1.1",
 654            "User-Agent: $useragent",
 655            "Cookie: dkey=$dkey",
 656            "Connection: close";
 657   push @hh,"Range: bytes=$seek-" if $seek;
 658
 659   # HTTPS needs a new connection for actually downloading the file
 660   serverconnect($server,$port) if $opt_P and $port == 443;
 661   sendheader("$server:$port",@hh);
 662   $_ = <$SH>;
 663   die "$0: no response from fex server $server\n" unless $_;
 664   s/\r//;
 665
 666   if (/^HTTP\/[\d.]+ 2/) {
 667     warn "<-- $_" if $opt_v;
 668     while (<$SH>) {
 669       s/\r//;
 670       warn "<-- $_" if $opt_v;
 671       last if /^\r?\n/;
 672       if (/^Content-length:\s*(\d+)/i) {
 673         $length = $1;
 674       } elsif (/^X-Size: (\d+)/i) {
 675         $filesize = $1;
 676       }
 677     }
 678   } else {
 679     s/HTTP\/[\d.]+ \d+ //;
 680     die "$0: bad server reply: $_";
 681   }
 682
 683   if ($pipe) {
 684     *X = *STDOUT;
 685   } else {
 686     if ($opt_s and $opt_s eq $download) {
 687       open X,'>',$download or die "$0: cannot write to \"$download\" - $!\n";
 688       $checkstorage = $filesize unless $nocheck;
 689     } else {
 690       if (-e $file and not $opt_o) {
 691         die "$0: destination file \"$file\" does already exist\n";
 692       }
 693       if ($seek) {
 694         open X,'>>',$download or die "$0: cannot write to \"$download\" - $!\n";
 695       } else {
 696         open X,'>',$download or die "$0: cannot write to \"$download\" - $!\n";
 697         $checkstorage = $filesize unless $nocheck;
 698       }
 699     }
 700     if ($checkstorage and not $nocheck) {
 701       my $t0 = my $t1 = my $t2 = time;
 702       my $n = 0;
 703       my $buf = '.' x M;
 704       my $storagetest = $file.'.test';
 705       my $error = "$0: cannot write \"$storagetest\"";
 706       open $storagetest,'>',$storagetest or die "$error - $!\n";
 707       print STDERR "checking storage...\r";
 708       while (-s $storagetest < $checkstorage) {
 709         syswrite $storagetest,$buf or do {
 710           unlink $storagetest;
 711           die "\n$error - $!\n";
 712         };
 713         $n++;
 714         $t2 = int(time);
 715         if ($t2 > $t1) {
 716           print STDERR "checking storage... ".$n." MB\r";
 717           $t1 = $t2;
 718         }
 719       }
 720       close $storagetest or do {
 721         unlink $storagetest;
 722         die "\n$error - $!\n";
 723       };
 724       print STDERR "checking storage... ".$n." MB ok!\n";
 725       unlink $storagetest;
 726       if (time-$t0 > 25) {
 727         # retry after timeout
 728         serverconnect($server,$port);
 729         return(download($server,$port,$fop,'nocheck'))
 730       }
 731     }
 732   }
 733
 734   $t0 = $t1 = $t2 = int(time);
 735   $tb = $B = 0;
 736   printf STDERR "resuming at byte %s\n",$seek if $seek;
 737   print $rcamel[0] if ${'opt_+'};
 738   while ($B < $length and $b = read $SH,$buf,$bs) {
 739     syswrite X,$buf;
 740     $B += $b;
 741     $tb += $b;
 742     $bt += $b;
 743     $t2 = time;
 744     if (${'opt_+'} and int($t2*10)>$tc) {
 745       print $rcamel[$tc%2+1];
 746       $tc = int($t2*10);
 747     }
 748     if (int($t2) > $t1) {
 749       $kBs = int($bt/k/($t2-$t1));
 750       $kBs = int($tb/k/($t2-$t0)) if $kBs < 10;
 751       $t1 = $t2;
 752       $bt = 0;
 753       # smaller block size is better on slow links
 754       $bs = 4096 if $bs>4096 and $tb/($t2-$t0)<65536;
 755       if ($tb<10*M) {
 756         printf STDERR "%s: %d kB (%d%%) %d kB/s \r",
 757                       $download,
 758                       int(($tb+$seek)/k),
 759                       int(($tb+$seek)/($length+$seek)*100),
 760                       $kBs;
 761       } else {
 762         printf STDERR "%s: %d MB (%d%%) %d kB/s        \r",
 763                       $download,
 764                       int(($tb+$seek)/M),
 765                       int(($tb+$seek)/($length+$seek)*100),
 766                       $kBs;
 767       }
 768     }
 769     if ($opt_m) {
 770       if ($t2 == $t0 and $B > $opt_m*k) {
 771         print "\nsleeping...\r" if $opt_v;
 772         sleep 1;
 773       } else {
 774         while ($t2 > $t0 and $tb/k/($t2-$t0) > $opt_m) {
 775           print "\nsleeping...\r" if $opt_v;
 776           sleep 1;
 777           $t2 = time;
 778         }
 779       }
 780     }
 781   }
 782   close $SH;
 783   close X;
 784
 785   print $rcamel[2] if ${'opt_+'};
 786
 787   $tt = $t2-$t0;
 788   $tm = int($tt/60);
 789   $ts = $tt-$tm*60;
 790   $kBs = int($tb/k/($tt||1));
 791   if ($seek) {
 792     printf STDERR "$file: %d MB, last %d MB in %d s (%d kB/s)      \n",
 793                   int(($tb+$seek)/M),int($tb/M),$tt,$kBs;
 794   } else {
 795     printf STDERR "$file: %d MB in %d s (%d kB/s)      \n",
 796                   int($tb/M),$tt,$kBs;
 797   }
 798
 799   if ($tb != $length) {
 800     if ($windoof) {
 801       exec "\"$0\" @ARGV";
 802       exit;
 803     } else {
 804       die "$0: $server annouced $length bytes, but only $tb bytes has been read\n";
 805     }
 806   }
 807
 808   unless ($pipe or -p $download or -c $download) {
 809     my @s = stat $file if -e $file;
 810     rename $download,$file
 811       or die "$0: cannot rename \"$download\" to \"$file\" - $!\n";
 812     chmod $s[2],$file if @s;
 813   }
 814
 815   return sprintf("%s/%s",getcwd(),$file);
 816 }
 817
 818
 819 sub list {
 820   my $cmd = "$fexsend -L";
 821   $cmd .= " -i $opt_i" if $opt_i;
 822   if ($opt_v) {
 823     $cmd .= " -v";
 824     warn "$cmd\n";
 825   }
 826   open $cmd,"$cmd|" or die "$0: cannot run $cmd : $!\n";
 827   open $ffl,'>',$ffl or die "$0: cannot open $ffl : $!\n";
 828   my $n;
 829   while (<$cmd>) {
 830     if (/\d MB .*http/) {
 831       $n++;
 832       printf {$ffl} "%4d) %s",$n,$_;
 833       s:http[^\"]*/::;
 834       printf        "%4d) %s",$n,$_;
 835     } else {
 836       print;
 837       print {$ffl} $_;
 838     }
 839   }
 840 }
 841
 842
 843 sub locale {
 844   my $string = shift;
 845
 846   if ($CTYPE) {
 847     if ($CTYPE =~ /UTF-?8/i) {
 848       return $string;
 849     } elsif (grep { $CTYPE =~ /^$_$/i } Encode->encodings()) {
 850       return encode($CTYPE,$string);
 851     } else {
 852       return encode('ISO-8859-1',$string);
 853     }
 854   }
 855
 856   return $string;
 857 }
 858
 859
 860 sub pathsearch {
 861   my $prg = shift;
 862
 863   foreach my $dir (split(':',$ENV{PATH})) {
 864     return "$dir/$prg" if -x "$dir/$prg";
 865   }
 866 }
 867
 868
 869 {
 870   my $tty;
 871
 872   sub inquire {
 873     my $prompt = shift;
 874     my $default = shift;
 875     local $| = 1;
 876     local $_;
 877
 878     if (defined $default) {
 879       unless ($tty) {
 880         chomp($tty = `tty 2>/dev/null`);
 881         eval { local $^W; require "sys/ioctl.ph"; };
 882       }
 883
 884       if (defined(&TIOCSTI) and $tty and open($tty,'>',$tty)) {
 885         print $prompt;
 886         # push default answer into keyboard buffer
 887         foreach my $a (split("",$default)) { ioctl($tty,&TIOCSTI,$a) }
 888         chomp($_ = <STDIN>||'');
 889       } else {
 890         $prompt =~ s/([\?:=]\s*)/ [$default]$1/ or $prompt .= " [$default] ";
 891         print $prompt;
 892         chomp($_ = <STDIN>||'');
 893         $_ = $default unless length;
 894       }
 895     } else {
 896       print $prompt;
 897       chomp($_ = <STDIN>||'');
 898     }
 899
 900     return $_;
 901   }
 902 }
 903
 904
 905 ### common functions ###
 906
 907
 908 sub mtime {
 909   my @d = localtime((stat shift)[9]);
 910   return sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
 911 }
 912
 913
 914 sub urldecode {
 915   local $_ = shift;
 916   s/\%([a-f\d]{2})/chr(hex($1))/ige;
 917   return $_;
 918 }
 919
 920
 921 sub get_ssl_env {
 922   # set SSL/TLS options
 923   $SSL{SSL_verify_mode} = $ENV{SSLVERIFY} if defined($ENV{SSLVERIFY});
 924   foreach my $opt (qw(
 925     SSL_version
 926     SSL_cipher_list
 927     SSL_verify_mode
 928     SSL_ca_path
 929     SSL_ca_file)
 930   ) {
 931     my $env = uc($opt);
 932     $env =~ s/_//g;
 933     $SSL{$opt} = $ENV{$env} if defined($ENV{$env});
 934   }
 935
 936   if ($SSL{SSL_verify_mode}) {
 937     &search_ca;
 938     unless ($SSL{SSL_ca_path} or $SSL{SSL_ca_file}) {
 939       die "$0: \$SSLVERIFYMODE, but not valid \$SSLCAPATH or \$SSLCAFILE\n";
 940     }
 941   } elsif (defined($SSL{SSL_verify_mode})) {
 942     # user has set SSLVERIFY=0 !
 943   } else {
 944     &search_ca;
 945     $SSL{SSL_verify_mode} = 1 if $SSL{SSL_ca_path} or $SSL{SSL_ca_file};
 946   }
 947 }
 948
 949 sub search_ca {
 950   local $_;
 951   return if $SSL{SSL_ca_file} or $SSL{SSL_ca_path};
 952   foreach (qw(/etc/ssl/certs/ca-certificates.crt)) {
 953     if (-f) {
 954       $SSL{SSL_ca_file} = $_;
 955       return;
 956     }
 957   }
 958   foreach (qw(/etc/ssl/certs /etc/pki/tls/certs)) {
 959     if (-f) {
 960       $SSL{SSL_ca_path} = $_;
 961       return;
 962     }
 963   }
 964 }
 965
 966
 967 sub serverconnect {
 968   my ($server,$port) = @_;
 969   my $connect = "CONNECT $server:$port HTTP/1.1";
 970   local $_;
 971
 972   if ($proxy) {
 973     tcpconnect(split(':',$proxy));
 974     if ($https) {
 975       printf "--> %s\n",$connect if $opt_v;
 976       nvtsend($connect,"");
 977       $_ = <$SH>;
 978       s/\r//;
 979       printf "<-- $_"if $opt_v;
 980       unless (/^HTTP.1.. 200/) {
 981         die "$0: proxy error : $_";
 982       }
 983       &enable_ssl;
 984       $SH = IO::Socket::SSL->start_SSL($SH,%SSL);
 985     }
 986   } else {
 987     tcpconnect($server,$port);
 988   }
 989 #  if ($https and $opt_v) {
 990 #    printf "%s\n",$SH->get_cipher();
 991 #  }
 992 }
 993
 994
 995 # set up tcp/ip connection
 996 sub tcpconnect {
 997   my ($server,$port) = @_;
 998
 999   if ($SH) {
1000     close $SH;
1001     undef $SH;
1002   }
1003
1004   if ($https) {
1005     # eval "use IO::Socket::SSL qw(debug3)";
1006     &enable_ssl;
1007     $SH = IO::Socket::SSL->new(
1008       PeerAddr => $server,
1009       PeerPort => $port,
1010       Proto    => 'tcp',
1011       %SSL
1012     );
1013   } else {
1014     $SH = IO::Socket::INET->new(
1015       PeerAddr => $server,
1016       PeerPort => $port,
1017       Proto    => 'tcp',
1018     );
1019   }
1020
1021   if ($SH) {
1022     autoflush $SH 1;
1023     binmode $SH;
1024   } else {
1025     die "$0: cannot connect $server:$port - $@\n";
1026   }
1027
1028   print "TCPCONNECT to $server:$port\n" if $opt_v;
1029 }
1030
1031
1032 sub enable_ssl {
1033   eval "use IO::Socket::SSL";
1034   die "$0: cannot load IO::Socket::SSL\n" if $@;
1035   eval '$SSL{SSL_verify_mode} = 0 if Net::SSLeay::SSLeay() <= 9470143';
1036   if ($opt_v) {
1037     foreach my $v (keys %SSL) {
1038       printf "%s => %s\n",$v,$SSL{$v};
1039     }
1040   }
1041 }
1042
1043
1044 sub sendheader {
1045   my $sp = shift;
1046   my @head = @_;
1047   my $head;
1048
1049   push @head,"Host: $sp";
1050
1051   foreach $head (@head) {
1052     print "--> $head\n" if $opt_v;
1053     print {$SH} $head,"\r\n";
1054   }
1055   print "-->\n" if $opt_v;
1056   print {$SH} "\r\n";
1057 }
1058
1059
1060 sub nvtsend {
1061   local $SIG{PIPE} = sub { $sigpipe = "@_" };
1062
1063   $sigpipe = '';
1064
1065   die "$0: internal error: no active network handle\n" unless $SH;
1066   die "$0: remote host has closed the link\n" unless $SH->connected;
1067
1068   foreach my $line (@_) {
1069     print {$SH} $line,"\r\n";
1070     if ($sigpipe) {
1071       undef $SH;
1072       return 0;
1073     }
1074   }
1075
1076   return 1;
1077 }
1078
1079
1080 sub quote {
1081   local $_ = shift;
1082   s/([^\w\@\/%^,.=+_:+-])/\\$1/g;
1083   return $_;
1084 }
1085
1086
1087 sub debug {
1088   print "## DEBUG: @_\n" if $DEBUG;
1089 }
1090
1091
1092 # from MIME::Base64::Perl
1093 sub encode_b64 {
1094   my $res = "";
1095   my $eol = "\n";
1096   my $padding;
1097
1098   pos($_[0]) = 0;
1099   $res = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
1100   $res =~ tr|` -_|AA-Za-z0-9+/|;
1101   $padding = (3-length($_[0])%3)%3;
1102   $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
1103   return $res;
1104 }