home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_utl.zip / lwp-download.cmd < prev    next >
OS/2 REXX Batch file  |  1997-11-28  |  6KB  |  234 lines
  1. extproc perl -S
  2. #!f:/perllib/bin/perl -w
  3.     eval 'exec perl -S $0 "$@"'
  4.     if 0;
  5.  
  6. # $Id: lwp-download.PL,v 1.4 1997/09/26 12:11:13 aas Exp $
  7.  
  8. =head1 NAME
  9.  
  10. lwp-download - fetch large files from the net
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.  lwp-download [-a] <url> [<local file>]
  15.  
  16. =head1 DESCRIPTION
  17.  
  18. The I<lwp-download> program will down load the document specified by the URL
  19. given as the first command line argument to a local file.  The local
  20. filename used to save the document is guessed from the URL unless
  21. specified as the second command line argument.
  22.  
  23. The I<lwp-download> program is implemented using the I<libwww-perl>
  24. library.  It is better suited to down load big files than the
  25. I<lwp-request> program because it does not store the file in memory.
  26. Another benefit is that it will keep you updated about it's progress
  27. and that you don't have any options to worry about.
  28.  
  29. Use the C<-a> option to save the file in text (ascii) mode.
  30.  
  31. =head1 EXAMPLE
  32.  
  33. Fetch the newest and greatest perl version:
  34.  
  35.  $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz
  36.  Saving to 'latest.tar.gz'...
  37.  1.47 MB received in 22 seconds (68.7 KB/sec)
  38.  
  39. =head1 AUTHOR
  40.  
  41. Gisle Aas <gisle@aas.no>
  42.  
  43. =cut
  44.  
  45. use LWP::UserAgent;
  46. use LWP::MediaTypes;
  47. use URI::URL;
  48. use strict;
  49.  
  50. my $progname = $0;
  51. $progname =~ s,.*/,,;    # only basename left in progname
  52. $progname =~ s/\.\w*$//; # strip extension if any
  53.  
  54. #parse option
  55. use Getopt::Std;
  56. my %opts;
  57. unless (getopts('a', \%opts)) {
  58.     usage();
  59. }
  60. my $opt_a = $opts{a}; # save in binary mode
  61.  
  62. my $url = url(shift || usage());
  63. my $argfile = shift;
  64.  
  65. my $ua = new LWP::UserAgent;
  66.  
  67. $ua->agent("lwp-download/0.1 " . $ua->agent);
  68.  
  69. my $req = new HTTP::Request GET => $url;
  70.  
  71. my $file;      # name of file we download into
  72. my $length;    # total number of bytes to download
  73. my $flength;   # formatted length
  74. my $size = 0;  # number of bytes received
  75. my $start_t;   # start time of download
  76. my $last_dur;  # time of last callback
  77.  
  78. my $shown = 0; # has we called the show() function yet
  79.  
  80. $SIG{INT} = sub { die "Interrupted\n"; };
  81.  
  82. $| = 1;  # autoflush
  83.  
  84. my $res = $ua->request($req,
  85.   sub {
  86.       unless($file) {
  87.       my $res = $_[1];
  88.       unless ($argfile) {
  89.           # must find a suitable name to use.  First thing
  90.           # to do is to look for the "Content-Disposition"
  91.           # header defined by RFC1806.  This is also supported
  92.           # by Netscape
  93.           my $cd = $res->header("Content-Disposition");
  94.           if ($cd && $cd =~ /\bfilename\s*=\s*(\S+)/) {
  95.           $file = $1;
  96.           $file =~ s/;$//;
  97.           $file =~ s/^([\"\'])(.*)\1$/$2/;
  98.           }
  99.         
  100.           # if this fails we try to make something from the URL
  101.           unless ($file) {
  102.           my $req = $res->request;  # now always there
  103.           my $rurl = $req ? $req->url : $url;
  104.           
  105.           $file = ($rurl->path_components)[-1];
  106.           unless (length $file) {
  107.               $file = "index";
  108.               my $suffix = media_suffix($res->content_type);
  109.               $file .= ".$suffix" if $suffix;
  110.           } elsif ($rurl->scheme eq 'ftp' ||
  111.                $file =~ /\.tgz$/      ||
  112.                $file =~ /\.tar(\.(Z|gz))?$/
  113.               ) {
  114.               # leave the filename as it was
  115.           } else {
  116.               my $ct = guess_media_type($file);
  117.               unless ($ct eq $res->content_type) {
  118.               # need a better suffix for this type
  119.               my $suffix = media_suffix($res->content_type);
  120.               $file .= ".$suffix" if $suffix;
  121.               }
  122.           }
  123.           }
  124.  
  125.           # Check if the file is already present
  126.           if (-f $file && -t) {
  127.           print "Overwrite $file? [y] ";
  128.           my $ans = <STDIN>;
  129.           exit if !defined($ans) || !($ans =~ /^y?\n/);
  130.           } else {
  131.           print "Saving to '$file'...\n";
  132.           }
  133.       } else {
  134.           $file = $argfile;
  135.       }
  136.       open(FILE, ">$file") || die "Can't open $file: $!";
  137.           binmode FILE unless $opt_a;
  138.       $length = $res->content_length;
  139.       $flength = fbytes($length) if defined $length;
  140.       $start_t = time;
  141.       $last_dur = 0;
  142.       }
  143.       $size += length($_[0]);
  144.       print FILE $_[0];
  145.       if (defined $length) {
  146.       my $dur  = time - $start_t;
  147.       if ($dur != $last_dur) {  # don't update too often
  148.           $last_dur = $dur;
  149.           my $perc = $size / $length;
  150.           my $speed;
  151.           $speed = fbytes($size/$dur) . "/sec" if $dur > 3;
  152.           my $secs_left = fduration($dur/$perc - $dur);
  153.           $perc = int($perc*100);
  154.           my $show = "$perc% of $flength";
  155.           $show .= " (at $speed, $secs_left remaining)" if $speed;
  156.           show($show);
  157.       }
  158.       } else {
  159.       show( fbytes($size) . " received");
  160.       }
  161.   }
  162. );
  163.  
  164. if ($res->is_success || $res->message =~ /^Interrupted/) {
  165.     show("");  # clear text
  166.     print "\r";
  167.     print fbytes($size);
  168.     print " of ", fbytes($length) if defined($length) && $length != $size;
  169.     print " received";
  170.     my $dur = time - $start_t;
  171.     if ($dur) {
  172.     my $speed = fbytes($size/$dur) . "/sec";
  173.     print " in ", fduration($dur), " ($speed)";
  174.     }
  175.     print "\n";
  176.     my $died = $res->header("X-Died");
  177.     if ($died || !$res->is_success) {
  178.     if (-t) {
  179.         print "Transfer aborted.  Delete $file? [n] ";
  180.         my $ans = <STDIN>;
  181.         unlink($file) if defined($ans) && $ans =~ /^y\n/;
  182.     } else {
  183.         print "Transfer aborted, $file kept\n";
  184.     }
  185.     }
  186. } else {
  187.     print "\n" if $shown;
  188.     print "$progname: Can't download: ", $res->code, " ", $res->message, "\n";
  189.     exit 1;
  190. }
  191.  
  192.  
  193. sub fbytes
  194. {
  195.     my $n = int(shift);
  196.     if ($n >= 1024 * 1024) {
  197.     return sprintf "%.3g MB", $n / (1024.0 * 1024);
  198.     } elsif ($n >= 1024) {
  199.     return sprintf "%.3g KB", $n / 1024.0;
  200.     } else {
  201.     return "$n bytes";
  202.     }
  203. }
  204.  
  205. sub fduration
  206. {
  207.     use integer;
  208.     my $secs = int(shift);
  209.     my $hours = $secs / (60*60);
  210.     $secs -= $hours * 60*60;
  211.     my $mins = $secs / 60;
  212.     $secs %= 60;
  213.     if ($hours) {
  214.     return "$hours hours $mins minutes";
  215.     } elsif ($mins >= 2) {
  216.     return "$mins minutes";
  217.     } else {
  218.     $secs += $mins * 60;
  219.     return "$secs seconds";
  220.     }
  221. }
  222.  
  223. sub show
  224. {
  225.     my $mess = shift;
  226.     print "\r$mess", (" " x (75 - length $mess));
  227.     $shown++;
  228. }
  229.  
  230. sub usage
  231. {
  232.     die "Usage: $progname [-a] <url> [<lpath>]\n";
  233. }
  234.