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