diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/bin/lwp-download')
| -rwxr-xr-x | Master/tlpkg/tlperl0/bin/lwp-download | 320 |
1 files changed, 320 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/bin/lwp-download b/Master/tlpkg/tlperl0/bin/lwp-download new file mode 100755 index 00000000000..a85ac551d9f --- /dev/null +++ b/Master/tlpkg/tlperl0/bin/lwp-download @@ -0,0 +1,320 @@ +#!/usr/bin/perl -w + +=head1 NAME + +lwp-download - Fetch large files from the web + +=head1 SYNOPSIS + +B<lwp-download> [B<-a>] <I<url>> [<I<local path>>] + +=head1 DESCRIPTION + +The B<lwp-download> program will save the file at I<url> to a local +file. + +If I<local path> is not specified, then the current directory is +assumed. + +If I<local path> is a directory, then the basename of the file to save +is picked up from the Content-Disposition header or the URL of the +response. If the file already exists, then B<lwp-download> will +prompt before it overwrites and will fail if its standard input is not +a terminal. This form of invocation will also fail is no acceptable +filename can be derived from the sources mentioned above. + +If I<local path> is not a directory, then it is simply used as the +path to save into. + +The I<lwp-download> program is implemented using the I<libwww-perl> +library. It is better suited to down load big files than the +I<lwp-request> program because it does not store the file in memory. +Another benefit is that it will keep you updated about its progress +and that you don't have much options to worry about. + +Use the C<-a> option to save the file in text (ascii) mode. Might +make a difference on dosish systems. + +=head1 EXAMPLE + +Fetch the newest and greatest perl version: + + $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz + Saving to 'latest.tar.gz'... + 11.4 MB received in 8 seconds (1.43 MB/sec) + +=head1 AUTHOR + +Gisle Aas <gisle@aas.no> + +=cut + +#' get emacs out of quote mode + +use strict; + +use LWP::UserAgent (); +use LWP::MediaTypes qw(guess_media_type media_suffix); +use URI (); +use HTTP::Date (); + +my $progname = $0; +$progname =~ s,.*/,,; # only basename left in progname +$progname =~ s,.*\\,, if $^O eq "MSWin32"; +$progname =~ s/\.\w*$//; # strip extension if any + +#parse option +use Getopt::Std; +my %opt; +unless (getopts('a', \%opt)) { + usage(); +} + +my $url = URI->new(shift || usage()); +my $argfile = shift; +usage() if defined($argfile) && !length($argfile); +my $VERSION = "5.827"; + +my $ua = LWP::UserAgent->new( + agent => "lwp-download/$VERSION ", + keep_alive => 1, + env_proxy => 1, +); + +my $file; # name of file we download into +my $length; # total number of bytes to download +my $flength; # formatted length +my $size = 0; # number of bytes received +my $start_t; # start time of download +my $last_dur; # time of last callback + +my $shown = 0; # have we called the show() function yet + +$SIG{INT} = sub { die "Interrupted\n"; }; + +$| = 1; # autoflush + +my $res = $ua->request(HTTP::Request->new(GET => $url), + sub { + unless(defined $file) { + my $res = $_[1]; + + my $directory; + if (defined $argfile && -d $argfile) { + ($directory, $argfile) = ($argfile, undef); + } + + unless (defined $argfile) { + # find a suitable name to use + $file = $res->filename; + + # if this fails we try to make something from the URL + unless ($file) { + my $req = $res->request; # not always there + my $rurl = $req ? $req->uri : $url; + + $file = ($rurl->path_segments)[-1]; + if (!defined($file) || !length($file)) { + $file = "index"; + my $suffix = media_suffix($res->content_type); + $file .= ".$suffix" if $suffix; + } + elsif ($rurl->scheme eq 'ftp' || + $file =~ /\.t[bg]z$/ || + $file =~ /\.tar(\.(Z|gz|bz2?))?$/ + ) { + # leave the filename as it was + } + else { + my $ct = guess_media_type($file); + unless ($ct eq $res->content_type) { + # need a better suffix for this type + my $suffix = media_suffix($res->content_type); + $file .= ".$suffix" if $suffix; + } + } + } + + # validate that we don't have a harmful filename now. The server + # might try to trick us into doing something bad. + if (!length($file) || + $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge) + { + die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n"; + } + + if (defined $directory) { + require File::Spec; + $file = File::Spec->catfile($directory, $file); + } + + # Check if the file is already present + if (-l $file) { + die "Will not save <$url> to link \"$file\".\nPlease override file name on the command line.\n"; + } + elsif (-f _) { + die "Will not save <$url> as \"$file\" without verification.\nEither run from terminal or override file name on the command line.\n" + unless -t; + $shown = 1; + print "Overwrite $file? [y] "; + my $ans = <STDIN>; + unless (defined($ans) && $ans =~ /^y?\n/) { + if (defined $ans) { + print "Ok, aborting.\n"; + } + else { + print "\nAborting.\n"; + } + exit 1; + } + $shown = 0; + } + elsif (-e _) { + die "Will not save <$url> as \"$file\". Path exists.\n"; + } + else { + print "Saving to '$file'...\n"; + } + } + else { + $file = $argfile; + } + open(FILE, ">$file") || die "Can't open $file: $!\n"; + binmode FILE unless $opt{a}; + $length = $res->content_length; + $flength = fbytes($length) if defined $length; + $start_t = time; + $last_dur = 0; + } + + print FILE $_[0] or die "Can't write to $file: $!\n"; + $size += length($_[0]); + + if (defined $length) { + my $dur = time - $start_t; + if ($dur != $last_dur) { # don't update too often + $last_dur = $dur; + my $perc = $size / $length; + my $speed; + $speed = fbytes($size/$dur) . "/sec" if $dur > 3; + my $secs_left = fduration($dur/$perc - $dur); + $perc = int($perc*100); + my $show = "$perc% of $flength"; + $show .= " (at $speed, $secs_left remaining)" if $speed; + show($show, 1); + } + } + else { + show( fbytes($size) . " received"); + } + } +); + +if (fileno(FILE)) { + close(FILE) || die "Can't write to $file: $!\n"; + + show(""); # clear text + print "\r"; + print fbytes($size); + print " of ", fbytes($length) if defined($length) && $length != $size; + print " received"; + my $dur = time - $start_t; + if ($dur) { + my $speed = fbytes($size/$dur) . "/sec"; + print " in ", fduration($dur), " ($speed)"; + } + print "\n"; + + if (my $mtime = $res->last_modified) { + utime time, $mtime, $file; + } + + if ($res->header("X-Died") || !$res->is_success) { + if (my $died = $res->header("X-Died")) { + print "$died\n"; + } + if (-t) { + print "Transfer aborted. Delete $file? [n] "; + my $ans = <STDIN>; + if (defined($ans) && $ans =~ /^y\n/) { + unlink($file) && print "Deleted.\n"; + } + elsif ($length > $size) { + print "Truncated file kept: ", fbytes($length - $size), " missing\n"; + } + else { + print "File kept.\n"; + } + exit 1; + } + else { + print "Transfer aborted, $file kept\n"; + } + } + exit 0; +} + +# Did not manage to create any file +print "\n" if $shown; +if (my $xdied = $res->header("X-Died")) { + print "$progname: Aborted\n$xdied\n"; +} +else { + print "$progname: ", $res->status_line, "\n"; +} +exit 1; + + +sub fbytes +{ + my $n = int(shift); + if ($n >= 1024 * 1024) { + return sprintf "%.3g MB", $n / (1024.0 * 1024); + } + elsif ($n >= 1024) { + return sprintf "%.3g KB", $n / 1024.0; + } + else { + return "$n bytes"; + } +} + +sub fduration +{ + use integer; + my $secs = int(shift); + my $hours = $secs / (60*60); + $secs -= $hours * 60*60; + my $mins = $secs / 60; + $secs %= 60; + if ($hours) { + return "$hours hours $mins minutes"; + } + elsif ($mins >= 2) { + return "$mins minutes"; + } + else { + $secs += $mins * 60; + return "$secs seconds"; + } +} + + +BEGIN { + my @ani = qw(- \ | /); + my $ani = 0; + + sub show + { + my($mess, $show_ani) = @_; + print "\r$mess" . (" " x (75 - length $mess)); + print $show_ani ? "$ani[$ani++]\b" : " "; + $ani %= @ani; + $shown++; + } +} + +sub usage +{ + die "Usage: $progname [-a] <url> [<lpath>]\n"; +} |