home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_utl.zip / lwp-rget.cmd < prev    next >
OS/2 REXX Batch file  |  1997-11-28  |  8KB  |  324 lines
  1. extproc perl -S
  2. #!f:/perllib/bin/perl -w
  3.     eval 'exec perl -S $0 "$@"'
  4.     if 0;
  5.  
  6. =head1 NAME
  7.  
  8. lwp-rget - Retrieve WWW documents recursively
  9.  
  10. =head1 SYNOPSIS
  11.  
  12.  lwp-rget [--verbose] [--depth=N] [--limit=N] [--prefix=URL] <URL>
  13.  lwp-rget --version
  14.  
  15. =head1 DESCRIPTION
  16.  
  17. This program will retrieve a document and store it in a local file.  It
  18. will follow any links found in the document and store these documents
  19. as well, patching links so that they refer to these local copies.
  20. This process continues until there are no more unvisited links or the
  21. process is stopped by the one or more of the limits which can be
  22. controlled by the command line arguments.
  23.  
  24. This program is useful if you want to make a local copy of a
  25. collection of documents or want to do web reading off-line.
  26.  
  27. All documents are stored as plain files in the current directory. The
  28. file names chosen are derived from the last component of URL paths.
  29.  
  30. The options are:
  31.  
  32. =over 3
  33.  
  34. =item --depth=I<n>
  35.  
  36. Limit the recursive level. Embedded images are always loaded, even if
  37. they fall outside the I<--depth>. This means that one can use
  38. I<--depth=0> in order to fetch a single document together with all
  39. inline graphics.
  40.  
  41. The default depth is 5.
  42.  
  43. =item --limit=I<n>
  44.  
  45. Limit the number of documents to get.  The default limit is 50.
  46.  
  47. =item --prefix=I<url_prefix>
  48.  
  49. Limit the links to follow. Only URLs that start the prefix string are
  50. followed.
  51.  
  52. The default prefix is set as the "directory" of the initial URL to
  53. follow.  For instance if we start lwp-rget with the URL
  54. C<http://www.sn.no/foo/bar.html>, then prefix will be set to
  55. C<http://www.sn.no/foo/>.
  56.  
  57. Use C<--prefix=''> if you don't want the fetching to be limited by any
  58. prefix.
  59.  
  60. =item --sleep=I<n>
  61.  
  62. Sleep I<n> seconds before retrieving each document. This options allows
  63. you to go slowly, not loading the server you visiting too much.
  64.  
  65. =item --verbose
  66.  
  67. Make more noise while running.
  68.  
  69. =item --quiet
  70.  
  71. Don't make any noise.
  72.  
  73. =item --version
  74.  
  75. Print program version number and quit.
  76.  
  77. =item --help
  78.  
  79. Print the usage message and quit.
  80.  
  81. =back
  82.  
  83. Before the program exits the name of the file, where the initial URL
  84. is stored, is printed on stdout.  All used filenames are also printed
  85. on stderr as they are loaded.  This printing can be suppressed with
  86. the I<--quiet> option.
  87.  
  88. =head1 SEE ALSO
  89.  
  90. L<lwp-request>, L<LWP>
  91.  
  92. =head1 AUTHOR
  93.  
  94. Gisle Aas <aas@sn.no>
  95.  
  96. =cut
  97.  
  98. use strict;
  99.  
  100. use Getopt::Long;
  101. use URI::URL;
  102. use LWP::MediaTypes qw(media_suffix);
  103.  
  104. use vars qw($VERSION);
  105. use vars qw($MAX_DEPTH $MAX_DOCS $PREFIX $VERBOSE $QUIET $SLEEP);
  106.  
  107. my $progname = $0;
  108. $progname =~ s|.*/||;  # only basename left
  109. $progname =~ s/\.\w*$//; #strip extension if any
  110.  
  111. $VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/);
  112.  
  113. #$Getopt::Long::debug = 1;
  114. #$Getopt::Long::ignorecase = 0;
  115.  
  116. # Defaults
  117. $MAX_DEPTH = 5;
  118. $MAX_DOCS  = 50;
  119.  
  120. GetOptions('version'  => \&print_version,
  121.        'help'     => \&usage,
  122.        'depth=i'  => \$MAX_DEPTH,
  123.        'limit=i'  => \$MAX_DOCS,
  124.        'verbose!' => \$VERBOSE,
  125.            'quiet!'   => \$QUIET,
  126.        'sleep=i'  => \$SLEEP,
  127.        'prefix:s' => \$PREFIX,
  128.       ) || usage();
  129.  
  130. sub print_version {
  131.     require LWP;
  132.     my $DISTNAME = 'libwww-perl-' . LWP::Version();
  133.     print <<"EOT";
  134. This is lwp-rget version $VERSION ($DISTNAME)
  135.  
  136. Copyright 1996, Gisle Aas.
  137.  
  138. This program is free software; you can redistribute it and/or
  139. modify it under the same terms as Perl itself.
  140. EOT
  141.     exit 0;
  142. }
  143.  
  144. my $start_url = shift || usage();
  145. usage() if @ARGV;
  146.  
  147. require LWP::UserAgent;
  148. my $ua = new LWP::UserAgent;
  149. $ua->agent("$progname/$VERSION " . $ua->agent);
  150. $ua->env_proxy;
  151.  
  152. unless (defined $PREFIX) {
  153.     $PREFIX = url($start_url);   # limit to URLs below this one
  154.     eval {
  155.     $PREFIX->eparams(undef);
  156.     $PREFIX->equery(undef);
  157.     };
  158.  
  159.     $_ = $PREFIX->epath;
  160.     s|[^/]+$||;
  161.     $PREFIX->epath($_);
  162.     $PREFIX = $PREFIX->as_string;
  163. }
  164.  
  165.  
  166. print <<"" if $VERBOSE;
  167. START     = $start_url
  168. MAX_DEPTH = $MAX_DEPTH
  169. MAX_DOCS  = $MAX_DOCS
  170. PREFIX    = $PREFIX
  171.  
  172.  
  173. my $no_docs = 0;
  174. my %seen = ();     # mapping from URL => local_file
  175.  
  176. my $filename = fetch($start_url);
  177. print "$filename\n" unless $QUIET;
  178.  
  179. sub fetch
  180. {
  181.     my($url, $type, $depth) = @_;
  182.     $url = url($url) unless ref($url);
  183.     $type  ||= 'a';
  184.     $type = 'img' if $type eq 'body';  # might be the background attribute
  185.     $depth ||= 0;
  186.  
  187.     # Print the URL before we start checking...
  188.     my $out = (" " x $depth) . $url . " ";
  189.     $out .= "." x (60 - length($out));
  190.     print STDERR $out . " " if $VERBOSE;
  191.  
  192.     # Can't get mailto things
  193.     if ($url->scheme eq 'mailto') {
  194.     print STDERR "*skipping mailto*\n" if $VERBOSE;
  195.     return $url->as_string;
  196.     }
  197.  
  198.     # The $plain_url is a URL without the fragment part
  199.     my $plain_url = $url->clone;
  200.     $plain_url->frag(undef);
  201.  
  202.     # If we already have it, then there is nothing to be done
  203.     my $seen = $seen{$plain_url->as_string};
  204.     if ($seen) {
  205.     my $frag = $url->frag;
  206.     $seen .= "#$frag" if defined($frag);
  207.     print STDERR "$seen (again)\n" if $VERBOSE;
  208.     return $seen;
  209.     }
  210.  
  211.     # Too much or too deep
  212.     if ($depth > $MAX_DEPTH and $type ne 'img') {
  213.     print STDERR "*too deep*\n" if $VERBOSE;
  214.     return $url;
  215.     }
  216.     if ($no_docs > $MAX_DOCS) {
  217.     print STDERR "*too many*\n" if $VERBOSE;
  218.     return $url;
  219.     }
  220.  
  221.     # Check PREFIX, but not for <IMG ...> links
  222.     if ($type ne 'img' and  $url->as_string !~ /^\Q$PREFIX/o) {
  223.     print STDERR "*outsider*\n" if $VERBOSE;
  224.     return $url->as_string;
  225.     }
  226.  
  227.     # Fetch document 
  228.     $no_docs++;
  229.     sleep($SLEEP) if $SLEEP;
  230.     my $res = $ua->request(HTTP::Request->new(GET => $url));
  231.  
  232.     # Check outcome
  233.     if ($res->is_success) {
  234.     my $doc = $res->content;
  235.     my $ct = $res->content_type;
  236.     my $name = find_name($res->request->url, $ct);
  237.     print STDERR "$name\n" unless $QUIET;
  238.     $seen{$plain_url->as_string} = $name;
  239.  
  240.     # If the file is HTML, then we look for internal links
  241.     if ($ct eq "text/html") {
  242.         # Save an unprosessed version of the HTML document.  This
  243.         # both reserves the name used, and it also ensures that we
  244.         # don't loose everything if this program is killed before
  245.         # we finish.
  246.         save($name, $doc);
  247.         my $base = $res->base;
  248.         # Follow and substitute links...
  249.         $doc =~ s/(<\s*(img|a|body)\b[^>]+\b(?:src|href|background)\s*=\s*)(["']?)([^>\s]+)\3/new_link($1, lc($2), $3, $4, $base, $depth+1)/gie;       #"; # help emacs
  250.     }
  251.     save($name, $doc);
  252.     return $name;                      
  253.     } else {
  254.     print STDERR $res->code . " " . $res->message . "\n" if $VERBOSE;
  255.     $seen{$plain_url->as_string} = "*BAD*";
  256.     return "*BAD*";
  257.     }
  258. }
  259.  
  260. sub new_link
  261. {
  262.     my($pre, $type, $quote, $url, $base, $depth) = @_;
  263.     $url = url($url, $base)->abs;
  264.     $pre . $quote . fetch($url, $type, $depth) . $quote;
  265. }
  266.  
  267. sub find_name
  268. {
  269.     my($url, $type) = @_;
  270.     #print "find_name($url, $type)\n";
  271.     $url = url($url) unless ref($url);
  272.  
  273.     my $path = $url->path;
  274.  
  275.     # trim path until only the basename is left
  276.     $path =~ s|.*/||;
  277.     $path =~ s|\..*||;
  278.     $path = "index" unless length($path);
  279.  
  280.     my $extra = "";  # something to make the name unique
  281.     my $suffix = media_suffix($type);
  282.  
  283.     while (1) {
  284.     # Construct a new file name
  285.     my $file = $path . $extra;
  286.     $file .= ".$suffix" if $suffix;
  287.     # Check if it is unique
  288.     return $file unless -f $file;
  289.  
  290.     # Try something extra
  291.     unless ($extra) {
  292.         $extra = "001";
  293.         next;
  294.     }
  295.     $extra++;
  296.     }
  297. }
  298.  
  299.  
  300. sub save
  301. {
  302.     my $name = shift;
  303.     #print "save($name,...)\n";
  304.     open(FILE, ">$name") || die "Can't save $name: $!";
  305.     binmode FILE;
  306.     print FILE $_[0];
  307.     close(FILE);
  308. }
  309.  
  310. sub usage
  311. {
  312.     die <<"";
  313. Usage: $progname [options] <URL>
  314. Allowed options are:
  315.   --depth=N         Maximum depth to traverse (default is $MAX_DEPTH)
  316.   --limit=N         A limit on the number documents to get (default is $MAX_DOCS)
  317.   --version         Print version number and quit
  318.   --verbose         More output
  319.   --quiet           No output
  320.   --sleep=SECS      Sleep between gets, ie. go slowly
  321.   --prefix=PREFIX   Limit URLs to follow to those which begin with PREFIX
  322.  
  323. }
  324.