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