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