home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _1e7253af15a776313a5d0cf12b9b5a52 < prev    next >
Encoding:
Text File  |  2000-03-15  |  8.2 KB  |  334 lines
  1. #
  2. # $Id: Simple.pm,v 1.32 1999/03/20 07:37:36 gisle Exp $
  3.  
  4. =head1 NAME
  5.  
  6. get, head, getprint, getstore, mirror - Procedural LWP interface
  7.  
  8. =head1 SYNOPSIS
  9.  
  10.  perl -MLWP::Simple -e 'getprint "http://www.sn.no"'
  11.  
  12.  use LWP::Simple;
  13.  $content = get("http://www.sn.no/")
  14.  if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) {
  15.      ...
  16.  }
  17.  
  18.  if (is_success(getprint("http://www.sn.no/"))) {
  19.      ...
  20.  }
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. This interface is intended for those who want a simplified view of the
  25. libwww-perl library.  It should also be suitable for one-liners.  If
  26. you need more control or access to the header fields in the requests
  27. sent and responses received you should use the full object oriented
  28. interface provided by the C<LWP::UserAgent> module.
  29.  
  30. The following functions are provided (and exported) by this module:
  31.  
  32. =over 3
  33.  
  34. =item get($url)
  35.  
  36. The get() function will fetch the document identified by the given URL
  37. and return it.  It returns C<undef> if it fails.  The $url argument can
  38. be either a simple string or a reference to a URI object.
  39.  
  40. You will not be able to examine the response code or response headers
  41. (like 'Content-Type') when you are accessing the web using this
  42. function.  If you need that information you should use the full OO
  43. interface (see L<LWP::UserAgent>).
  44.  
  45. =item head($url)
  46.  
  47. Get document headers. Returns the following 5 values if successful:
  48. ($content_type, $document_length, $modified_time, $expires, $server)
  49.  
  50. Returns an empty list if it fails.  In scalar context returns TRUE if
  51. successful.
  52.  
  53. =item getprint($url)
  54.  
  55. Get and print a document identified by a URL. The document is printed
  56. to STDOUT as data is received from the network.  If the request fails,
  57. then the status code and message are printed on STDERR.  The return
  58. value is the HTTP response code.
  59.  
  60. =item getstore($url, $file)
  61.  
  62. Gets a document identified by a URL and stores it in the file. The
  63. return value is the HTTP response code.
  64.  
  65. =item mirror($url, $file)
  66.  
  67. Get and store a document identified by a URL, using
  68. I<If-modified-since>, and checking the I<Content-Length>.  Returns
  69. the HTTP response code.
  70.  
  71. =back
  72.  
  73. This module also exports the HTTP::Status constants and procedures.
  74. These can be used when you check the response code from getprint(),
  75. getstore() and mirror().  The constants are:
  76.  
  77.    RC_CONTINUE
  78.    RC_SWITCHING_PROTOCOLS
  79.    RC_OK
  80.    RC_CREATED
  81.    RC_ACCEPTED
  82.    RC_NON_AUTHORITATIVE_INFORMATION
  83.    RC_NO_CONTENT
  84.    RC_RESET_CONTENT
  85.    RC_PARTIAL_CONTENT
  86.    RC_MULTIPLE_CHOICES
  87.    RC_MOVED_PERMANENTLY
  88.    RC_MOVED_TEMPORARILY
  89.    RC_SEE_OTHER
  90.    RC_NOT_MODIFIED
  91.    RC_USE_PROXY
  92.    RC_BAD_REQUEST
  93.    RC_UNAUTHORIZED
  94.    RC_PAYMENT_REQUIRED
  95.    RC_FORBIDDEN
  96.    RC_NOT_FOUND
  97.    RC_METHOD_NOT_ALLOWED
  98.    RC_NOT_ACCEPTABLE
  99.    RC_PROXY_AUTHENTICATION_REQUIRED
  100.    RC_REQUEST_TIMEOUT
  101.    RC_CONFLICT
  102.    RC_GONE
  103.    RC_LENGTH_REQUIRED
  104.    RC_PRECONDITION_FAILED
  105.    RC_REQUEST_ENTITY_TOO_LARGE
  106.    RC_REQUEST_URI_TOO_LARGE
  107.    RC_UNSUPPORTED_MEDIA_TYPE
  108.    RC_INTERNAL_SERVER_ERROR
  109.    RC_NOT_IMPLEMENTED
  110.    RC_BAD_GATEWAY
  111.    RC_SERVICE_UNAVAILABLE
  112.    RC_GATEWAY_TIMEOUT
  113.    RC_HTTP_VERSION_NOT_SUPPORTED
  114.  
  115. The HTTP::Status classification functions are:
  116.  
  117. =over 3
  118.  
  119. =item is_success($rc)
  120.  
  121. True if response code indicated a successful request.
  122.  
  123. =item is_error($rc)
  124.  
  125. True if response code indicated that an error occured.
  126.  
  127. =back
  128.  
  129. The module will also export the LWP::UserAgent object as C<$ua> if you
  130. ask for it explicitly.
  131.  
  132. The user agent created by this module will identify itself as
  133. "LWP::Simple/#.##" (where "#.##" is the libwww-perl version number)
  134. and will initialize its proxy defaults from the environment (by
  135. calling $ua->env_proxy).
  136.  
  137. =head1 SEE ALSO
  138.  
  139. L<LWP>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>,
  140. L<lwp-mirror>
  141.  
  142. =cut
  143.  
  144.  
  145. package LWP::Simple;
  146.  
  147. use strict;
  148. use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION);
  149.  
  150. require Exporter;
  151.  
  152. @EXPORT = qw(get head getprint getstore mirror);
  153. @EXPORT_OK = qw($ua);
  154.  
  155. # I really hate this.  I was a bad idea to do it in the first place.
  156. # Wonder how to get rid of it???  (It even makes LWP::Simple 7% slower
  157. # for trivial tests)
  158. use HTTP::Status;
  159. push(@EXPORT, @HTTP::Status::EXPORT);
  160.  
  161.  
  162. $VERSION = sprintf("%d.%02d", q$Revision: 1.32 $ =~ /(\d+)\.(\d+)/);
  163. $FULL_LWP++ if grep {lc($_) eq "http_proxy"} keys %ENV;
  164.  
  165.  
  166. sub import
  167. {
  168.     my $pkg = shift;
  169.     my $callpkg = caller;
  170.     if (grep $_ eq '$ua', @_) {
  171.     $FULL_LWP++;
  172.     _init_ua();
  173.     }
  174.     Exporter::export($pkg, $callpkg, @_);
  175. }
  176.  
  177.  
  178. sub _init_ua
  179. {
  180.     require LWP;
  181.     require LWP::UserAgent;
  182.     require HTTP::Status;
  183.     require HTTP::Date;
  184.     $ua = new LWP::UserAgent;  # we create a global UserAgent object
  185.     my $ver = $LWP::VERSION = $LWP::VERSION;  # avoid warning
  186.     $ua->agent("LWP::Simple/$LWP::VERSION");
  187.     $ua->env_proxy;
  188. }
  189.  
  190.  
  191. sub get ($)
  192. {
  193.     %loop_check = ();
  194.     goto \&_get;
  195. }
  196.  
  197.  
  198. sub get_old ($)
  199. {
  200.     my($url) = @_;
  201.     _init_ua() unless $ua;
  202.  
  203.     my $request = HTTP::Request->new(GET => $url);
  204.     my $response = $ua->request($request);
  205.  
  206.     return $response->content if $response->is_success;
  207.     return undef;
  208. }
  209.  
  210.  
  211. sub head ($)
  212. {
  213.     my($url) = @_;
  214.     _init_ua() unless $ua;
  215.  
  216.     my $request = HTTP::Request->new(HEAD => $url);
  217.     my $response = $ua->request($request);
  218.  
  219.     if ($response->is_success) {
  220.     return $response unless wantarray;
  221.     return (scalar $response->header('Content-Type'),
  222.         scalar $response->header('Content-Length'),
  223.         HTTP::Date::str2time($response->header('Last-Modified')),
  224.         HTTP::Date::str2time($response->header('Expires')),
  225.         scalar $response->header('Server'),
  226.            );
  227.     }
  228.     return;
  229. }
  230.  
  231.  
  232. sub getprint ($)
  233. {
  234.     my($url) = @_;
  235.     _init_ua() unless $ua;
  236.  
  237.     my $request = HTTP::Request->new(GET => $url);
  238.     local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
  239.     my $callback = sub { print $_[0] };
  240.     if ($^O eq "MacOS") {
  241.     $callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] }
  242.     }
  243.     my $response = $ua->request($request, $callback);
  244.     unless ($response->is_success) {
  245.     print STDERR $response->status_line, " <URL:$url>\n";
  246.     }
  247.     $response->code;
  248. }
  249.  
  250.  
  251. sub getstore ($$)
  252. {
  253.     my($url, $file) = @_;
  254.     _init_ua() unless $ua;
  255.  
  256.     my $request = HTTP::Request->new(GET => $url);
  257.     my $response = $ua->request($request, $file);
  258.  
  259.     $response->code;
  260. }
  261.  
  262.  
  263. sub mirror ($$)
  264. {
  265.     my($url, $file) = @_;
  266.     _init_ua() unless $ua;
  267.     my $response = $ua->mirror($url, $file);
  268.     $response->code;
  269. }
  270.  
  271.  
  272. sub _get
  273. {
  274.     my $url = shift;
  275.     my $ret;
  276.     if (!$FULL_LWP && $url =~ m,^http://([^/:]+)(?::(\d+))?(/\S*)?$,) {
  277.     my $host = $1;
  278.     my $port = $2 || 80;
  279.     my $path = $3;
  280.     $path = "/" unless defined($path);
  281.     return _trivial_http_get($host, $port, $path);
  282.     } else {
  283.         _init_ua() unless $ua;
  284.     my $request = HTTP::Request->new(GET => $url);
  285.     my $response = $ua->request($request);
  286.     return $response->is_success ? $response->content : undef;
  287.     }
  288. }
  289.  
  290.  
  291. sub _trivial_http_get
  292. {
  293.    my($host, $port, $path) = @_;
  294.    #print "HOST=$host, PORT=$port, PATH=$path\n";
  295.  
  296.    require IO::Socket;
  297.    local($^W) = 0;
  298.    my $sock = IO::Socket::INET->new(PeerAddr => $host,
  299.                                     PeerPort => $port,
  300.                                     Proto    => 'tcp',
  301.                                     Timeout  => 60) || return;
  302.    $sock->autoflush;
  303.    my $netloc = $host;
  304.    $netloc .= ":$port" if $port != 80;
  305.    print $sock join("\015\012" =>
  306.                     "GET $path HTTP/1.0",
  307.                     "Host: $netloc",
  308.                     "User-Agent: lwp-trivial/$VERSION",
  309.                     "", "");
  310.  
  311.    my $buf = "";
  312.    my $n;
  313.    1 while $n = sysread($sock, $buf, 8*1024, length($buf));
  314.    return undef unless defined($n);
  315.  
  316.    if ($buf =~ m,^HTTP/\d+\.\d+\s+(\d+)[^\012]*\012,) {
  317.        my $code = $1;
  318.        #print "CODE=$code\n$buf\n";
  319.        if ($code =~ /^30[1237]/ && $buf =~ /\012Location:\s*(\S+)/) {
  320.            # redirect
  321.            my $url = $1;
  322.            return undef if $loop_check{$url}++;
  323.            return _get($url);
  324.        }
  325.        return undef unless $code =~ /^2/;
  326.        $buf =~ s/.+?\015?\012\015?\012//s;  # zap header
  327.    }
  328.  
  329.    return $buf;
  330. }
  331.  
  332.  
  333. 1;
  334.