home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _f338b430b28bbd1e550f6fef5c22b29d < prev    next >
Text File  |  2000-03-23  |  15KB  |  598 lines
  1. #!perl -w
  2.  
  3. #line 18
  4.  
  5. =head1 NAME
  6.  
  7. lwp-rget - Retrieve WWW documents recursively
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.  lwp-rget [--verbose] [--auth=USER:PASS] [--depth=N] [--hier] [--iis]
  12.       [--keepext=mime/type[,mime/type]] [--limit=N] [--nospace]
  13.       [--prefix=URL] [--referer=URL] [--sleep=N] [--tolower] <URL>
  14.  lwp-rget --version
  15.  
  16. =head1 DESCRIPTION
  17.  
  18. This program will retrieve a document and store it in a local file.  It
  19. will follow any links found in the document and store these documents
  20. as well, patching links so that they refer to these local copies.
  21. This process continues until there are no more unvisited links or the
  22. process is stopped by the one or more of the limits which can be
  23. controlled by the command line arguments.
  24.  
  25. This program is useful if you want to make a local copy of a
  26. collection of documents or want to do web reading off-line.
  27.  
  28. All documents are stored as plain files in the current directory. The
  29. file names chosen are derived from the last component of URL paths.
  30.  
  31. The options are:
  32.  
  33. =over 3
  34.  
  35. =item --auth=USER:PASS<n>
  36.  
  37. Set the authentication credentials to user "USER" and password "PASS" if
  38. any restricted parts of the web site are hit.  If there are restricted
  39. parts of the web site and authentication credentials are not available,
  40. those pages will not be downloaded.
  41.  
  42. =item --depth=I<n>
  43.  
  44. Limit the recursive level. Embedded images are always loaded, even if
  45. they fall outside the I<--depth>. This means that one can use
  46. I<--depth=0> in order to fetch a single document together with all
  47. inline graphics.
  48.  
  49. The default depth is 5.
  50.  
  51. =item --hier
  52.  
  53. Download files into a hierarchy that mimics the web site structure.
  54. The default is to put all files in the current directory.
  55.  
  56. =item --referer=I<URI>
  57.  
  58. Set the value of the referer header for the initial request.  The
  59. special value C<"NONE"> can be used to suppress the referer header in
  60. any of subsequent requests.
  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: 1.19 $ =~ /(\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) unless ref($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.     $req->referer($referer) if $referer && !$SUPPRESS_REFERER;
  303.     my $res = $ua->request($req);
  304.  
  305.     # Check outcome
  306.     if ($res->is_success) {
  307.     my $doc = $res->content;
  308.     my $ct = $res->content_type;
  309.     my $name = find_name($res->request->url, $ct);
  310.     print STDERR "$name\n" unless $QUIET;
  311.     $seen{$plain_url->as_string} = $name;
  312.  
  313.     # If the file is HTML, then we look for internal links
  314.     if ($ct eq "text/html") {
  315.         # Save an unprosessed version of the HTML document.     This
  316.         # both reserves the name used, and it also ensures that we
  317.         # don't loose everything if this program is killed before
  318.         # we finish.
  319.         save($name, $doc);
  320.         my $base = $res->base;
  321.  
  322.         # Follow and substitute links...
  323.         $doc =~
  324. s/
  325.   (
  326.     <(img|a|body|area|frame|td)\b   # some interesting tag
  327.     [^>]+                # still inside tag (not strictly correct)
  328.     \b(?:src|href|background)        # some link attribute
  329.     \s*=\s*                # =
  330.   )
  331.     (?:                    # scope of OR-ing
  332.      (")([^"]*)"    |        # value in double quotes  OR
  333.      (')([^']*)'    |        # value in single quotes  OR
  334.         ([^\s>]+)            # quoteless value
  335.     )
  336. /
  337.   new_link($1, lc($2), $3||$5, HTML::Entities::decode($4||$6||$7),
  338.            $base, $name, "$url", $depth+1)
  339. /giex;
  340.        # XXX
  341.        # The regular expression above is not strictly correct.
  342.        # It is not really possible to parse HTML with a single
  343.        # regular expression, but it is faster.  Tags that might
  344.        # confuse us include:
  345.        #    <a alt="href" href=link.html>
  346.        #    <a alt=">" href="link.html">
  347.        #
  348.     }
  349.     save($name, $doc);
  350.     return $name;
  351.     } else {
  352.     print STDERR $res->code . " " . $res->message . "\n" if $VERBOSE;
  353.     $seen{$plain_url->as_string} = $url->as_string;
  354.     return $url->as_string;
  355.     }
  356. }
  357.  
  358. sub new_link
  359. {
  360.     my($pre, $type, $quote, $url, $base, $localbase, $referer, $depth) = @_;
  361.  
  362.     $url = protect_frag_spaces($url);
  363.  
  364.     $url = fetch(url($url, $base)->abs, $type, $referer, $depth);
  365.     $url = url("file:$url", "file:$localbase")->rel
  366.     unless $url =~ /^[.+\-\w]+:/;
  367.  
  368.     $url = unprotect_frag_spaces($url);
  369.  
  370.     return $pre . $quote . $url . $quote;
  371. }
  372.  
  373.  
  374. sub protect_frag_spaces
  375. {
  376.     my ($url) = @_;
  377.  
  378.     $url = $url->as_string if (ref($url));
  379.  
  380.     if ($url =~ m/^([^#]*#)(.+)$/)
  381.     {
  382.       my ($base, $frag) = ($1, $2);
  383.       $frag =~ s/ /%20/g;
  384.       $url = $base . $frag;
  385.     }
  386.  
  387.     return $url;
  388. }
  389.  
  390.  
  391. sub unprotect_frag_spaces
  392. {
  393.     my ($url) = @_;
  394.  
  395.     $url = $url->as_string if (ref($url));
  396.  
  397.     if ($url =~ m/^([^#]*#)(.+)$/)
  398.     {
  399.       my ($base, $frag) = ($1, $2);
  400.       $frag =~ s/%20/ /g;
  401.       $url = $base . $frag;
  402.     }
  403.  
  404.     return $url;
  405. }
  406.  
  407.  
  408. sub fix_backslashes
  409. {
  410.     my ($url) = @_;
  411.     my ($base, $frag);
  412.  
  413.     $url = $url->as_string if (ref($url));
  414.  
  415.     if ($url =~ m/([^#]+)(#.*)/)
  416.     {
  417.       ($base, $frag) = ($1, $2);
  418.     }
  419.     else
  420.     {
  421.       $base = $url;
  422.       $frag = "";
  423.     }
  424.  
  425.     $base =~ tr/\\/\//;
  426.     $base =~ s/%5[cC]/\//g;    # URL-encoded back slash is %5C
  427.  
  428.     return $base . $frag;
  429. }
  430.  
  431.  
  432. sub to_lower
  433. {
  434.     my ($url) = @_;
  435.     my $was_object = 0;
  436.  
  437.     if (ref($url))
  438.     {
  439.       $url = $url->as_string;
  440.       $was_object = 1;
  441.     }
  442.  
  443.     if ($url =~ m/([^#]+)(#.*)/)
  444.     {
  445.       $url = lc($1) . $2;
  446.     }
  447.     else
  448.     {
  449.       $url = lc($url);
  450.     }
  451.  
  452.     if ($was_object == 1)
  453.     {
  454.       return url($url);
  455.     }
  456.     else
  457.     {
  458.       return $url;
  459.     }
  460. }
  461.  
  462.  
  463. sub translate_spaces
  464. {
  465.     my ($url) = @_;
  466.     my ($base, $frag);
  467.  
  468.     $url = $url->as_string if (ref($url));
  469.  
  470.     if ($url =~ m/([^#]+)(#.*)/)
  471.     {
  472.       ($base, $frag) = ($1, $2);
  473.     }
  474.     else
  475.     {
  476.       $base = $url;
  477.       $frag = "";
  478.     }
  479.  
  480.     $base =~ s/^ *//;    # Remove initial spaces from base
  481.     $base =~ s/ *$//;    # Remove trailing spaces from base
  482.  
  483.     $base =~ tr/ /_/;
  484.     $base =~ s/%20/_/g; # URL-encoded space is %20
  485.  
  486.     return $base . $frag;
  487. }
  488.  
  489.  
  490. sub mkdirp
  491. {
  492.     my($directory, $mode) = @_;
  493.     my @dirs = split(/\//, $directory);
  494.     my $path = shift(@dirs);   # build it as we go
  495.     my $result = 1;   # assume it will work
  496.  
  497.     unless (-d $path) {
  498.     $result &&= mkdir($path, $mode);
  499.     }
  500.  
  501.     foreach (@dirs) {
  502.     $path .= "/$_";
  503.     if ( ! -d $path) {
  504.         $result &&= mkdir($path, $mode);
  505.     }
  506.     }
  507.  
  508.     return $result;
  509. }
  510.  
  511.  
  512. sub find_name
  513. {
  514.     my($url, $type) = @_;
  515.     #print "find_name($url, $type)\n";
  516.  
  517.     # Translate spaces in URL to underscores (_) if $NOSPACE defined
  518.     $url = translate_spaces($url) if (defined $NOSPACE);
  519.  
  520.     # Translate URL to lowercase if $TOLOWER defined
  521.     $url = to_lower($url) if (defined $TOLOWER);
  522.  
  523.     $url = url($url) unless ref($url);
  524.  
  525.     my $path = $url->path;
  526.  
  527.     # trim path until only the basename is left
  528.     $path =~ s|(.*/)||;
  529.     my $dirname = ".$1";
  530.     if (!$HIER) {
  531.     $dirname = "";
  532.     } elsif (! -d $dirname) {
  533.     mkdirp($dirname, 0775);
  534.     }
  535.  
  536.     my $extra = "";  # something to make the name unique
  537.     my $suffix;
  538.  
  539.     if ($KEEPEXT{lc($type)}) {
  540.         $suffix = ($path =~ m/\.(.*)/) ? $1 : "";
  541.     } else {
  542.         $suffix = media_suffix($type);
  543.     }
  544.  
  545.     $path =~ s|\..*||;    # trim suffix
  546.     $path = "index" unless length $path;
  547.  
  548.     while (1) {
  549.     # Construct a new file name
  550.     my $file = $dirname . $path . $extra;
  551.     $file .= ".$suffix" if $suffix;
  552.     # Check if it is unique
  553.     return $file unless -f $file;
  554.  
  555.     # Try something extra
  556.     unless ($extra) {
  557.         $extra = "001";
  558.         next;
  559.     }
  560.     $extra++;
  561.     }
  562. }
  563.  
  564.  
  565. sub save
  566. {
  567.     my $name = shift;
  568.     #print "save($name,...)\n";
  569.     open(FILE, ">$name") || die "Can't save $name: $!";
  570.     binmode FILE;
  571.     print FILE $_[0];
  572.     close(FILE);
  573. }
  574.  
  575.  
  576. sub usage
  577. {
  578.     die <<"";
  579. Usage: $progname [options] <URL>
  580. Allowed options are:
  581.   --auth=USER:PASS  Set authentication credentials for web site
  582.   --depth=N        Maximum depth to traverse (default is $MAX_DEPTH)
  583.   --hier        Download into hierarchy (not all files into cwd)
  584.   --referer=URI     Set initial referer header (or "NONE")
  585.   --iis            Workaround IIS 2.0 bug by sending "Accept: */*" MIME
  586.             header; translates backslashes (\\) to forward slashes (/)
  587.   --keepext=type    Keep file extension for MIME types (comma-separated list)
  588.   --limit=N        A limit on the number documents to get (default is $MAX_DOCS)
  589.   --nospace        Translate spaces URLs (not #fragments) to underscores (_)
  590.   --version        Print version number and quit
  591.   --verbose        More output
  592.   --quiet        No output
  593.   --sleep=SECS        Sleep between gets, ie. go slowly
  594.   --prefix=PREFIX   Limit URLs to follow to those which begin with PREFIX
  595.   --tolower        Translate all URLs to lowercase (useful with IIS servers)
  596.  
  597. }
  598.