home *** CD-ROM | disk | FTP | other *** search
/ PC World 2004 November / PCWorld_2004-11_cd.bin / software / topware / activeperl / ActivePerl-5.8.4.810-MSWin32-x86.exe / ActivePerl-5.8.4.810 / Perl / bin / lwp-rget < prev    next >
Text File  |  2004-06-01  |  16KB  |  608 lines
  1. #!/usr/bin/perl -w
  2.  
  3. =head1 NAME
  4.  
  5. lwp-rget - Retrieve web documents recursively
  6.  
  7. =head1 SYNOPSIS
  8.  
  9.  lwp-rget [--verbose] [--auth=USER:PASS] [--depth=N] [--hier] [--iis]
  10.       [--keepext=mime/type[,mime/type]] [--limit=N] [--nospace]
  11.       [--prefix=URL] [--referer=URL] [--sleep=N] [--tolower] <URL>
  12.  lwp-rget --version
  13.  
  14. =head1 DESCRIPTION
  15.  
  16. This program will retrieve a document and store it in a local file.  It
  17. will follow any links found in the document and store these documents
  18. as well, patching links so that they refer to these local copies.
  19. This process continues until there are no more unvisited links or the
  20. process is stopped by the one or more of the limits which can be
  21. controlled by the command line arguments.
  22.  
  23. This program is useful if you want to make a local copy of a
  24. collection of documents or want to do web reading off-line.
  25.  
  26. All documents are stored as plain files in the current directory. The
  27. file names chosen are derived from the last component of URL paths.
  28.  
  29. The options are:
  30.  
  31. =over 3
  32.  
  33. =item --auth=USER:PASS<n>
  34.  
  35. Set the authentication credentials to user "USER" and password "PASS" if
  36. any restricted parts of the web site are hit.  If there are restricted
  37. parts of the web site and authentication credentials are not available,
  38. those pages will not be downloaded.
  39.  
  40. =item --depth=I<n>
  41.  
  42. Limit the recursive level. Embedded images are always loaded, even if
  43. they fall outside the I<--depth>. This means that one can use
  44. I<--depth=0> in order to fetch a single document together with all
  45. inline graphics.
  46.  
  47. The default depth is 5.
  48.  
  49. =item --hier
  50.  
  51. Download files into a hierarchy that mimics the web site structure.
  52. The default is to put all files in the current directory.
  53.  
  54. =item --referer=I<URI>
  55.  
  56. Set the value of the Referer header for the initial request.  The
  57. special value C<"NONE"> can be used to suppress the Referer header in
  58. any of subsequent requests.  The Referer header will always be suppressed
  59. in all normal C<http> requests if the referring page was transmitted over
  60. C<https> as recommended in RFC 2616.
  61.  
  62. =item --iis
  63.  
  64. Sends an "Accept: */*" on all URL requests as a workaround for a bug in
  65. IIS 2.0.  If no Accept MIME header is present, IIS 2.0 returns with a
  66. "406 No acceptable objects were found" error.  Also converts any back
  67. slashes (\\) in URLs to forward slashes (/).
  68.  
  69. =item --keepext=I<mime/type[,mime/type]>
  70.  
  71. Keeps the current extension for the list MIME types.  Useful when
  72. downloading text/plain documents that shouldn't all be translated to
  73. *.txt files.
  74.  
  75. =item --limit=I<n>
  76.  
  77. Limit the number of documents to get.  The default limit is 50.
  78.  
  79. =item --nospace
  80.  
  81. Changes spaces in all URLs to underscore characters (_).  Useful when
  82. downloading files from sites serving URLs with spaces in them.    Does not
  83. remove spaces from fragments, e.g., "file.html#somewhere in here".
  84.  
  85. =item --prefix=I<url_prefix>
  86.  
  87. Limit the links to follow. Only URLs that start the prefix string are
  88. followed.
  89.  
  90. The default prefix is set as the "directory" of the initial URL to
  91. follow.     For instance if we start lwp-rget with the URL
  92. C<http://www.sn.no/foo/bar.html>, then prefix will be set to
  93. C<http://www.sn.no/foo/>.
  94.  
  95. Use C<--prefix=''> if you don't want the fetching to be limited by any
  96. prefix.
  97.  
  98. =item --sleep=I<n>
  99.  
  100. Sleep I<n> seconds before retrieving each document. This options allows
  101. you to go slowly, not loading the server you visiting too much.
  102.  
  103. =item --tolower
  104.  
  105. Translates all links to lowercase.  Useful when downloading files from
  106. IIS since it does not serve files in a case sensitive manner.
  107.  
  108. =item --verbose
  109.  
  110. Make more noise while running.
  111.  
  112. =item --quiet
  113.  
  114. Don't make any noise.
  115.  
  116. =item --version
  117.  
  118. Print program version number and quit.
  119.  
  120. =item --help
  121.  
  122. Print the usage message and quit.
  123.  
  124. =back
  125.  
  126. Before the program exits the name of the file, where the initial URL
  127. is stored, is printed on stdout.  All used filenames are also printed
  128. on stderr as they are loaded.  This printing can be suppressed with
  129. the I<--quiet> option.
  130.  
  131. =head1 SEE ALSO
  132.  
  133. L<lwp-request>, L<LWP>
  134.  
  135. =head1 AUTHOR
  136.  
  137. Gisle Aas <aas@sn.no>
  138.  
  139. =cut
  140.  
  141. use strict;
  142.  
  143. use Getopt::Long    qw(GetOptions);
  144. use URI::URL        qw(url);
  145. use LWP::MediaTypes qw(media_suffix);
  146. use HTML::Entities  ();
  147.  
  148. use vars qw($VERSION);
  149. use vars qw($MAX_DEPTH $MAX_DOCS $PREFIX $REFERER $VERBOSE $QUIET $SLEEP $HIER $AUTH $IIS $TOLOWER $NOSPACE %KEEPEXT);
  150.  
  151. my $progname = $0;
  152. $progname =~ s|.*/||;  # only basename left
  153. $progname =~ s/\.\w*$//; #strip extension if any
  154.  
  155. $VERSION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/);
  156.  
  157. #$Getopt::Long::debug = 1;
  158. #$Getopt::Long::ignorecase = 0;
  159.  
  160. # Defaults
  161. $MAX_DEPTH = 5;
  162. $MAX_DOCS  = 50;
  163.  
  164. GetOptions('version'  => \&print_version,
  165.        'help'     => \&usage,
  166.        'depth=i'  => \$MAX_DEPTH,
  167.        'limit=i'  => \$MAX_DOCS,
  168.        'verbose!' => \$VERBOSE,
  169.        'quiet!'   => \$QUIET,
  170.        'sleep=i'  => \$SLEEP,
  171.        'prefix:s' => \$PREFIX,
  172.        'referer:s'=> \$REFERER,
  173.        'hier'     => \$HIER,
  174.        'auth=s'   => \$AUTH,
  175.        'iis'      => \$IIS,
  176.        'tolower'  => \$TOLOWER,
  177.        'nospace'  => \$NOSPACE,
  178.        'keepext=s' => \$KEEPEXT{'OPT'},
  179.       ) || usage();
  180.  
  181. sub print_version {
  182.     require LWP;
  183.     my $DISTNAME = 'libwww-perl-' . LWP::Version();
  184.     print <<"EOT";
  185. This is lwp-rget version $VERSION ($DISTNAME)
  186.  
  187. Copyright 1996-1998, Gisle Aas.
  188.  
  189. This program is free software; you can redistribute it and/or
  190. modify it under the same terms as Perl itself.
  191. EOT
  192.     exit 0;
  193. }
  194.  
  195. my $start_url = shift || usage();
  196. usage() if @ARGV;
  197.  
  198. require LWP::UserAgent;
  199. my $ua = new LWP::UserAgent;
  200. $ua->agent("$progname/$VERSION " . $ua->agent);
  201. $ua->env_proxy;
  202.  
  203. unless (defined $PREFIX) {
  204.     $PREFIX = url($start_url);     # limit to URLs below this one
  205.     eval {
  206.     $PREFIX->eparams(undef);
  207.     $PREFIX->equery(undef);
  208.     };
  209.  
  210.     $_ = $PREFIX->epath;
  211.     s|[^/]+$||;
  212.     $PREFIX->epath($_);
  213.     $PREFIX = $PREFIX->as_string;
  214. }
  215.  
  216. %KEEPEXT = map { lc($_) => 1 } split(/\s*,\s*/, ($KEEPEXT{'OPT'}||0));
  217.  
  218. my $SUPPRESS_REFERER;
  219. $SUPPRESS_REFERER++ if ($REFERER || "") eq "NONE";
  220.  
  221. print <<"" if $VERBOSE;
  222. START      = $start_url
  223. MAX_DEPTH = $MAX_DEPTH
  224. MAX_DOCS  = $MAX_DOCS
  225. PREFIX      = $PREFIX
  226.  
  227. my $no_docs = 0;
  228. my %seen = ();       # mapping from URL => local_file
  229.  
  230. my $filename = fetch($start_url, undef, $REFERER);
  231. print "$filename\n" unless $QUIET;
  232.  
  233. sub fetch
  234. {
  235.     my($url, $type, $referer, $depth) = @_;
  236.  
  237.     # Fix http://sitename.com/../blah/blah.html to
  238.     #      http://sitename.com/blah/blah.html
  239.     $url = $url->as_string if (ref($url));
  240.     while ($url =~ s#(https?://[^/]+/)\.\.\/#$1#) {}
  241.  
  242.     # Fix backslashes (\) in URL if $IIS defined
  243.     $url = fix_backslashes($url) if (defined $IIS);
  244.  
  245.     $url = url($url);
  246.     $type  ||= 'a';
  247.     # Might be the background attribute
  248.     $type = 'img' if ($type eq 'body' || $type eq 'td');
  249.     $depth ||= 0;
  250.  
  251.     # Print the URL before we start checking...
  252.     my $out = (" " x $depth) . $url . " ";
  253.     $out .= "." x (60 - length($out));
  254.     print STDERR $out . " " if $VERBOSE;
  255.  
  256.     # Can't get mailto things
  257.     if ($url->scheme eq 'mailto') {
  258.     print STDERR "*skipping mailto*\n" if $VERBOSE;
  259.     return $url->as_string;
  260.     }
  261.  
  262.     # The $plain_url is a URL without the fragment part
  263.     my $plain_url = $url->clone;
  264.     $plain_url->frag(undef);
  265.  
  266.     # Check PREFIX, but not for <IMG ...> links
  267.     if ($type ne 'img' and  $url->as_string !~ /^\Q$PREFIX/o) {
  268.     print STDERR "*outsider*\n" if $VERBOSE;
  269.     return $url->as_string;
  270.     }
  271.  
  272.     # Translate URL to lowercase if $TOLOWER defined
  273.     $plain_url = to_lower($plain_url) if (defined $TOLOWER);
  274.  
  275.     # If we already have it, then there is nothing to be done
  276.     my $seen = $seen{$plain_url->as_string};
  277.     if ($seen) {
  278.     my $frag = $url->frag;
  279.     $seen .= "#$frag" if defined($frag);
  280.     $seen = protect_frag_spaces($seen);
  281.     print STDERR "$seen (again)\n" if $VERBOSE;
  282.     return $seen;
  283.     }
  284.  
  285.     # Too much or too deep
  286.     if ($depth > $MAX_DEPTH and $type ne 'img') {
  287.     print STDERR "*too deep*\n" if $VERBOSE;
  288.     return $url;
  289.     }
  290.     if ($no_docs > $MAX_DOCS) {
  291.     print STDERR "*too many*\n" if $VERBOSE;
  292.     return $url;
  293.     }
  294.  
  295.     # Fetch document 
  296.     $no_docs++;
  297.     sleep($SLEEP) if $SLEEP;
  298.     my $req = HTTP::Request->new(GET => $url);
  299.     # See: http://ftp.sunet.se/pub/NT/mirror-microsoft/kb/Q163/7/74.TXT
  300.     $req->header ('Accept', '*/*') if (defined $IIS);  # GIF/JPG from IIS 2.0
  301.     $req->authorization_basic(split (/:/, $AUTH)) if (defined $AUTH);
  302.     if ($referer && !$SUPPRESS_REFERER) {
  303.     if ($req->url->scheme eq 'http') {
  304.         # RFC 2616, section 15.1.3
  305.         $referer = url($referer) unless ref($referer);
  306.         undef $referer if ($referer->scheme || '') eq 'https';
  307.     }
  308.     $req->referer($referer) if $referer;
  309.     }
  310.     my $res = $ua->request($req);
  311.  
  312.     # Check outcome
  313.     if ($res->is_success) {
  314.     my $doc = $res->content;
  315.     my $ct = $res->content_type;
  316.     my $name = find_name($res->request->url, $ct);
  317.     print STDERR "$name\n" unless $QUIET;
  318.     $seen{$plain_url->as_string} = $name;
  319.  
  320.     # If the file is HTML, then we look for internal links
  321.     if ($ct eq "text/html") {
  322.         # Save an unprosessed version of the HTML document.     This
  323.         # both reserves the name used, and it also ensures that we
  324.         # don't loose everything if this program is killed before
  325.         # we finish.
  326.         save($name, $doc);
  327.         my $base = $res->base;
  328.  
  329.         # Follow and substitute links...
  330.         $doc =~
  331. s/
  332.   (
  333.     <(img|a|body|area|frame|td)\b   # some interesting tag
  334.     [^>]+                # still inside tag (not strictly correct)
  335.     \b(?:src|href|background)        # some link attribute
  336.     \s*=\s*                # =
  337.   )
  338.     (?:                    # scope of OR-ing
  339.      (")([^"]*)"    |        # value in double quotes  OR
  340.      (')([^']*)'    |        # value in single quotes  OR
  341.         ([^\s>]+)            # quoteless value
  342.     )
  343. /
  344.   new_link($1, lc($2), $3||$5, HTML::Entities::decode($4||$6||$7),
  345.            $base, $name, "$url", $depth+1)
  346. /giex;
  347.        # XXX
  348.        # The regular expression above is not strictly correct.
  349.        # It is not really possible to parse HTML with a single
  350.        # regular expression, but it is faster.  Tags that might
  351.        # confuse us include:
  352.        #    <a alt="href" href=link.html>
  353.        #    <a alt=">" href="link.html">
  354.        #
  355.     }
  356.     save($name, $doc);
  357.     return $name;
  358.     }
  359.     else {
  360.     print STDERR $res->code . " " . $res->message . "\n" if $VERBOSE;
  361.     $seen{$plain_url->as_string} = $url->as_string;
  362.     return $url->as_string;
  363.     }
  364. }
  365.  
  366. sub new_link
  367. {
  368.     my($pre, $type, $quote, $url, $base, $localbase, $referer, $depth) = @_;
  369.  
  370.     $url = protect_frag_spaces($url);
  371.  
  372.     $url = fetch(url($url, $base)->abs, $type, $referer, $depth);
  373.     $url = url("file:$url", "file:$localbase")->rel
  374.     unless $url =~ /^[.+\-\w]+:/;
  375.  
  376.     $url = unprotect_frag_spaces($url);
  377.  
  378.     return $pre . $quote . $url . $quote;
  379. }
  380.  
  381.  
  382. sub protect_frag_spaces
  383. {
  384.     my ($url) = @_;
  385.  
  386.     $url = $url->as_string if (ref($url));
  387.  
  388.     if ($url =~ m/^([^#]*#)(.+)$/)
  389.     {
  390.       my ($base, $frag) = ($1, $2);
  391.       $frag =~ s/ /%20/g;
  392.       $url = $base . $frag;
  393.     }
  394.  
  395.     return $url;
  396. }
  397.  
  398.  
  399. sub unprotect_frag_spaces
  400. {
  401.     my ($url) = @_;
  402.  
  403.     $url = $url->as_string if (ref($url));
  404.  
  405.     if ($url =~ m/^([^#]*#)(.+)$/)
  406.     {
  407.       my ($base, $frag) = ($1, $2);
  408.       $frag =~ s/%20/ /g;
  409.       $url = $base . $frag;
  410.     }
  411.  
  412.     return $url;
  413. }
  414.  
  415.  
  416. sub fix_backslashes
  417. {
  418.     my ($url) = @_;
  419.     my ($base, $frag);
  420.  
  421.     $url = $url->as_string if (ref($url));
  422.  
  423.     if ($url =~ m/([^#]+)(#.*)/)
  424.     {
  425.       ($base, $frag) = ($1, $2);
  426.     }
  427.     else
  428.     {
  429.       $base = $url;
  430.       $frag = "";
  431.     }
  432.  
  433.     $base =~ tr/\\/\//;
  434.     $base =~ s/%5[cC]/\//g;    # URL-encoded back slash is %5C
  435.  
  436.     return $base . $frag;
  437. }
  438.  
  439.  
  440. sub to_lower
  441. {
  442.     my ($url) = @_;
  443.     my $was_object = 0;
  444.  
  445.     if (ref($url))
  446.     {
  447.       $url = $url->as_string;
  448.       $was_object = 1;
  449.     }
  450.  
  451.     if ($url =~ m/([^#]+)(#.*)/)
  452.     {
  453.       $url = lc($1) . $2;
  454.     }
  455.     else
  456.     {
  457.       $url = lc($url);
  458.     }
  459.  
  460.     if ($was_object == 1)
  461.     {
  462.       return url($url);
  463.     }
  464.     else
  465.     {
  466.       return $url;
  467.     }
  468. }
  469.  
  470.  
  471. sub translate_spaces
  472. {
  473.     my ($url) = @_;
  474.     my ($base, $frag);
  475.  
  476.     $url = $url->as_string if (ref($url));
  477.  
  478.     if ($url =~ m/([^#]+)(#.*)/)
  479.     {
  480.       ($base, $frag) = ($1, $2);
  481.     }
  482.     else
  483.     {
  484.       $base = $url;
  485.       $frag = "";
  486.     }
  487.  
  488.     $base =~ s/^ *//;    # Remove initial spaces from base
  489.     $base =~ s/ *$//;    # Remove trailing spaces from base
  490.  
  491.     $base =~ tr/ /_/;
  492.     $base =~ s/%20/_/g; # URL-encoded space is %20
  493.  
  494.     return $base . $frag;
  495. }
  496.  
  497.  
  498. sub mkdirp
  499. {
  500.     my($directory, $mode) = @_;
  501.     my @dirs = split(/\//, $directory);
  502.     my $path = shift(@dirs);   # build it as we go
  503.     my $result = 1;   # assume it will work
  504.  
  505.     unless (-d $path) {
  506.     $result &&= mkdir($path, $mode);
  507.     }
  508.  
  509.     foreach (@dirs) {
  510.     $path .= "/$_";
  511.     if ( ! -d $path) {
  512.         $result &&= mkdir($path, $mode);
  513.     }
  514.     }
  515.  
  516.     return $result;
  517. }
  518.  
  519.  
  520. sub find_name
  521. {
  522.     my($url, $type) = @_;
  523.     #print "find_name($url, $type)\n";
  524.  
  525.     # Translate spaces in URL to underscores (_) if $NOSPACE defined
  526.     $url = translate_spaces($url) if (defined $NOSPACE);
  527.  
  528.     # Translate URL to lowercase if $TOLOWER defined
  529.     $url = to_lower($url) if (defined $TOLOWER);
  530.  
  531.     $url = url($url) unless ref($url);
  532.  
  533.     my $path = $url->path;
  534.  
  535.     # trim path until only the basename is left
  536.     $path =~ s|(.*/)||;
  537.     my $dirname = ".$1";
  538.     if (!$HIER) {
  539.     $dirname = "";
  540.     }
  541.     elsif (! -d $dirname) {
  542.     mkdirp($dirname, 0775);
  543.     }
  544.  
  545.     my $extra = "";  # something to make the name unique
  546.     my $suffix;
  547.  
  548.     if ($KEEPEXT{lc($type)}) {
  549.         $suffix = ($path =~ m/\.(.*)/) ? $1 : "";
  550.     }
  551.     else {
  552.         $suffix = media_suffix($type);
  553.     }
  554.  
  555.     $path =~ s|\..*||;    # trim suffix
  556.     $path = "index" unless length $path;
  557.  
  558.     while (1) {
  559.     # Construct a new file name
  560.     my $file = $dirname . $path . $extra;
  561.     $file .= ".$suffix" if $suffix;
  562.     # Check if it is unique
  563.     return $file unless -f $file;
  564.  
  565.     # Try something extra
  566.     unless ($extra) {
  567.         $extra = "001";
  568.         next;
  569.     }
  570.     $extra++;
  571.     }
  572. }
  573.  
  574.  
  575. sub save
  576. {
  577.     my $name = shift;
  578.     #print "save($name,...)\n";
  579.     open(FILE, ">$name") || die "Can't save $name: $!";
  580.     binmode FILE;
  581.     print FILE $_[0];
  582.     close(FILE);
  583. }
  584.  
  585.  
  586. sub usage
  587. {
  588.     print <<""; exit 1;
  589. Usage: $progname [options] <URL>
  590. Allowed options are:
  591.   --auth=USER:PASS  Set authentication credentials for web site
  592.   --depth=N        Maximum depth to traverse (default is $MAX_DEPTH)
  593.   --hier        Download into hierarchy (not all files into cwd)
  594.   --referer=URI     Set initial referer header (or "NONE")
  595.   --iis            Workaround IIS 2.0 bug by sending "Accept: */*" MIME
  596.             header; translates backslashes (\\) to forward slashes (/)
  597.   --keepext=type    Keep file extension for MIME types (comma-separated list)
  598.   --limit=N        A limit on the number documents to get (default is $MAX_DOCS)
  599.   --nospace        Translate spaces URLs (not #fragments) to underscores (_)
  600.   --version        Print version number and quit
  601.   --verbose        More output
  602.   --quiet        No output
  603.   --sleep=SECS        Sleep between gets, ie. go slowly
  604.   --prefix=PREFIX   Limit URLs to follow to those which begin with PREFIX
  605.   --tolower        Translate all URLs to lowercase (useful with IIS servers)
  606.  
  607. }
  608.