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