home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _bad32c86d733de5c256adcce9cdff09a < prev    next >
Text File  |  2000-03-15  |  21KB  |  711 lines
  1. # $Id: UserAgent.pm,v 1.68 1999/08/02 22:57:09 gisle Exp $
  2.  
  3. package LWP::UserAgent;
  4. use strict;
  5.  
  6. =head1 NAME
  7.  
  8. LWP::UserAgent - A WWW UserAgent class
  9.  
  10. =head1 SYNOPSIS
  11.  
  12.  require LWP::UserAgent;
  13.  $ua = new LWP::UserAgent;
  14.  
  15.  $request = new HTTP::Request('GET', 'file://localhost/etc/motd');
  16.  
  17.  $response = $ua->request($request); # or
  18.  $response = $ua->request($request, '/tmp/sss'); # or
  19.  $response = $ua->request($request, \&callback, 4096);
  20.  
  21.  sub callback { my($data, $response, $protocol) = @_; .... }
  22.  
  23. =head1 DESCRIPTION
  24.  
  25. The C<LWP::UserAgent> is a class implementing a simple World-Wide Web
  26. user agent in Perl. It brings together the HTTP::Request,
  27. HTTP::Response and the LWP::Protocol classes that form the rest of the
  28. core of libwww-perl library. For simple uses this class can be used
  29. directly to dispatch WWW requests, alternatively it can be subclassed
  30. for application-specific behaviour.
  31.  
  32. In normal use the application creates a UserAgent object, and then
  33. configures it with values for timeouts, proxies, name, etc. It next
  34. creates an instance of C<HTTP::Request> for the request that
  35. needs to be performed. This request is then passed to the UserAgent
  36. request() method, which dispatches it using the relevant protocol,
  37. and returns a C<HTTP::Response> object.
  38.  
  39. The basic approach of the library is to use HTTP style communication
  40. for all protocol schemes, i.e. you also receive an C<HTTP::Response>
  41. object for gopher or ftp requests.  In order to achieve even more
  42. similarity to HTTP style communications, gopher menus and file
  43. directories are converted to HTML documents.
  44.  
  45. The request() method can process the content of the response in one of
  46. three ways: in core, into a file, or into repeated calls to a
  47. subroutine.  You choose which one by the kind of value passed as the
  48. second argument to request().
  49.  
  50. The in core variant simply stores the content in a scalar 'content' attribute
  51. of the response object and is suitable for small
  52. HTML replies that might need further parsing.  This variant is used if
  53. the second argument is missing (or is undef).
  54.  
  55. The filename variant requires a scalar containing a filename as the
  56. second argument to request() and is suitable for large WWW objects
  57. which need to be written directly to the file without requiring large
  58. amounts of memory. In this case the response object returned from
  59. request() will have an empty content attribute.  If the request fails, then the
  60. content might not be empty, and the file will be untouched.
  61.  
  62. The subroutine variant requires a reference to callback routine as the
  63. second argument to request() and it can also take an optional chuck
  64. size as the third argument.  This variant can be used to construct
  65. "pipe-lined" processing, where processing of received chuncks can
  66. begin before the complete data has arrived.  The callback function is
  67. called with 3 arguments: the data received this time, a reference to
  68. the response object and a reference to the protocol object.  The
  69. response object returned from request() will have empty content.  If
  70. the request fails, then the the callback routine is
  71. called, and the response->content might not be empty.
  72.  
  73. The request can be aborted by calling die() in the callback
  74. routine.  The die message will be available as the "X-Died" special
  75. response header field.
  76.  
  77. The library also allows you to use a subroutine reference as
  78. content in the request object.  This subroutine should return the
  79. content (possibly in pieces) when called.  It should return an empty
  80. string when there is no more content.
  81.  
  82. =head1 METHODS
  83.  
  84. The following methods are available:
  85.  
  86. =over 4
  87.  
  88. =cut
  89.  
  90.  
  91. use vars qw(@ISA $VERSION);
  92.  
  93. require LWP::MemberMixin;
  94. @ISA = qw(LWP::MemberMixin);
  95. $VERSION = sprintf("%d.%02d", q$Revision: 1.68 $ =~ /(\d+)\.(\d+)/);
  96.  
  97. use HTTP::Request ();
  98. use HTTP::Response ();
  99. use HTTP::Date ();
  100.  
  101. use LWP ();
  102. use LWP::Debug ();
  103. use LWP::Protocol ();
  104.  
  105. use Carp ();
  106.  
  107.  
  108. =item $ua = new LWP::UserAgent;
  109.  
  110. Constructor for the UserAgent.  Returns a reference to a
  111. LWP::UserAgent object.
  112.  
  113. =cut
  114.  
  115. sub new
  116. {
  117.     my($class, $init) = @_;
  118.     LWP::Debug::trace('()');
  119.  
  120.     my $self;
  121.     if (ref $init) {
  122.     $self = $init->clone;
  123.     } else {
  124.     $self = bless {
  125.         'agent'       => "libwww-perl/$LWP::VERSION",
  126.         'from'        => undef,
  127.         'timeout'     => 3*60,
  128.         'proxy'       => undef,
  129.         'cookie_jar'  => undef,
  130.         'use_eval'    => 1,
  131.                 'parse_head'  => 1,
  132.                 'max_size'    => undef,
  133.         'no_proxy'    => [],
  134.     }, $class;
  135.     }
  136. }
  137.  
  138.  
  139. =item $ua->simple_request($request, [$arg [, $size]])
  140.  
  141. This method dispatches a single WWW request on behalf of a user, and
  142. returns the response received.  The C<$request> should be a reference
  143. to a C<HTTP::Request> object with values defined for at least the
  144. method() and uri() attributes.
  145.  
  146. If C<$arg> is a scalar it is taken as a filename where the content of
  147. the response is stored.
  148.  
  149. If C<$arg> is a reference to a subroutine, then this routine is called
  150. as chunks of the content is received.  An optional C<$size> argument
  151. is taken as a hint for an appropriate chunk size.
  152.  
  153. If C<$arg> is omitted, then the content is stored in the response
  154. object itself.
  155.  
  156. =cut
  157.  
  158. sub simple_request
  159. {
  160.     my($self, $request, $arg, $size) = @_;
  161.     local($SIG{__DIE__});  # protect agains user defined die handlers
  162.  
  163.     my($method, $url) = ($request->method, $request->url);
  164.  
  165.     # Check that we have a METHOD and a URL first
  166.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, "Method missing")
  167.     unless $method;
  168.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, "URL missing")
  169.     unless $url;
  170.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, "URL must be absolute")
  171.     unless $url->scheme;
  172.     
  173.  
  174.     LWP::Debug::trace("$method $url");
  175.  
  176.     # Locate protocol to use
  177.     my $scheme = '';
  178.     my $proxy = $self->_need_proxy($url);
  179.     if (defined $proxy) {
  180.     $scheme = $proxy->scheme;
  181.     } else {
  182.     $scheme = $url->scheme;
  183.     }
  184.     my $protocol;
  185.     eval {
  186.     $protocol = LWP::Protocol::create($scheme);
  187.     };
  188.     if ($@) {
  189.     $@ =~ s/\s+at\s+\S+\s+line\s+\d+\.?\s*//;  # remove file/line number
  190.     return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED, $@)
  191.     }
  192.  
  193.     # Extract fields that will be used below
  194.     my ($agent, $from, $timeout, $cookie_jar,
  195.         $use_eval, $parse_head, $max_size) =
  196.       @{$self}{qw(agent from timeout cookie_jar
  197.                   use_eval parse_head max_size)};
  198.  
  199.     # Set User-Agent and From headers if they are defined
  200.     $request->header('User-Agent' => $agent) if $agent;
  201.     $request->header('From' => $from) if $from;
  202.     $request->header('Range' => "bytes=0-$max_size") if $max_size;
  203.     $cookie_jar->add_cookie_header($request) if $cookie_jar;
  204.  
  205.     # Transfer some attributes to the protocol object
  206.     $protocol->parse_head($parse_head);
  207.     $protocol->max_size($max_size);
  208.     
  209.     my $response;
  210.     if ($use_eval) {
  211.     # we eval, and turn dies into responses below
  212.     eval {
  213.         $response = $protocol->request($request, $proxy,
  214.                        $arg, $size, $timeout);
  215.     };
  216.     if ($@) {
  217.         $@ =~ s/\s+at\s+\S+\s+line\s+\d+\.?\s*//;
  218.         $response =
  219.           HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  220.                   $@);
  221.     }
  222.     } else {
  223.     $response = $protocol->request($request, $proxy,
  224.                        $arg, $size, $timeout);
  225.     # XXX: Should we die unless $response->is_success ???
  226.     }
  227.  
  228.     $response->request($request);  # record request for reference
  229.     $cookie_jar->extract_cookies($response) if $cookie_jar;
  230.     $response->header("Client-Date" => HTTP::Date::time2str(time));
  231.     return $response;
  232. }
  233.  
  234.  
  235. =item $ua->request($request, $arg [, $size])
  236.  
  237. Process a request, including redirects and security.  This method may
  238. actually send several different simple requests.
  239.  
  240. The arguments are the same as for C<simple_request()>.
  241.  
  242. =cut
  243.  
  244. sub request
  245. {
  246.     my($self, $request, $arg, $size, $previous) = @_;
  247.  
  248.     LWP::Debug::trace('()');
  249.  
  250.     my $response = $self->simple_request($request, $arg, $size);
  251.  
  252.     my $code = $response->code;
  253.     $response->previous($previous) if defined $previous;
  254.  
  255.     LWP::Debug::debug('Simple result: ' . HTTP::Status::status_message($code));
  256.  
  257.     if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
  258.     $code == &HTTP::Status::RC_MOVED_TEMPORARILY) {
  259.  
  260.     # Make a copy of the request and initialize it with the new URI
  261.     my $referral = $request->clone;
  262.  
  263.     # And then we update the URL based on the Location:-header.
  264.     my $referral_uri = $response->header('Location');
  265.     {
  266.         # Some servers erroneously return a relative URL for redirects,
  267.         # so make it absolute if it not already is.
  268.         local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
  269.         my $base = $response->base;
  270.         $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
  271.                     ->abs($base);
  272.     }
  273.  
  274.     $referral->url($referral_uri);
  275.  
  276.     return $response unless $self->redirect_ok($referral);
  277.  
  278.     # Check for loop in the redirects
  279.     my $count = 0;
  280.     my $r = $response;
  281.     while ($r) {
  282.         if (++$count > 13 ||
  283.                 $r->request->url->as_string eq $referral_uri->as_string) {
  284.         $response->header("Client-Warning" =>
  285.                   "Redirect loop detected");
  286.         return $response;
  287.         }
  288.         $r = $r->previous;
  289.     }
  290.  
  291.     return $self->request($referral, $arg, $size, $response);
  292.  
  293.     } elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
  294.          $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
  295.         )
  296.     {
  297.     my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
  298.     my $ch_header = $proxy ?  "Proxy-Authenticate" : "WWW-Authenticate";
  299.     my $challenge = $response->header($ch_header);
  300.     unless (defined $challenge) {
  301.         $response->header("Client-Warning" => 
  302.                   "Missing Authenticate header");
  303.         return $response;
  304.     }
  305.  
  306.     require HTTP::Headers::Util;
  307.     $challenge =~ tr/,/;/;  # "," is used to separate auth-params!!
  308.     ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
  309.     my $scheme = lc(shift(@$challenge));
  310.     shift(@$challenge); # no value
  311.     $challenge = { @$challenge };  # make rest into a hash
  312.     for (keys %$challenge) {       # make sure all keys are lower case
  313.         $challenge->{lc $_} = delete $challenge->{$_};
  314.     }
  315.  
  316.     unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
  317.         $response->header("Client-Warning" => 
  318.                   "Bad authentication scheme '$scheme'");
  319.         return $response;
  320.     }
  321.     $scheme = $1;  # untainted now
  322.     my $class = "LWP::Authen::\u$scheme";
  323.     $class =~ s/-/_/g;
  324.     
  325.     no strict 'refs';
  326.     unless (%{"$class\::"}) {
  327.         # try to load it
  328.         eval "require $class";
  329.         if ($@) {
  330.         if ($@ =~ /^Can\'t locate/) {
  331.             $response->header("Client-Warning" =>
  332.                       "Unsupport authentication scheme '$scheme'");
  333.         } else {
  334.             $response->header("Client-Warning" => $@);
  335.         }
  336.         return $response;
  337.         }
  338.     }
  339.     return $class->authenticate($self, $proxy, $challenge, $response,
  340.                     $request, $arg, $size);
  341.     }
  342.     return $response;
  343. }
  344.  
  345.  
  346. =item $ua->redirect_ok
  347.  
  348. This method is called by request() before it tries to do any
  349. redirects.  It should return a true value if a redirect is allowed
  350. to be performed. Subclasses might want to override this.
  351.  
  352. The default implementation will return FALSE for POST request and TRUE
  353. for all others.
  354.  
  355. =cut
  356.  
  357. sub redirect_ok
  358. {
  359.     # draft-ietf-http-v10-spec-02.ps from www.ics.uci.edu, specify:
  360.     #
  361.     # If the 30[12] status code is received in response to a request using
  362.     # the POST method, the user agent must not automatically redirect the
  363.     # request unless it can be confirmed by the user, since this might change
  364.     # the conditions under which the request was issued.
  365.  
  366.     my($self, $request) = @_;
  367.     return 0 if $request->method eq "POST";
  368.     1;
  369. }
  370.  
  371.  
  372. =item $ua->credentials($netloc, $realm, $uname, $pass)
  373.  
  374. Set the user name and password to be used for a realm.  It is often more
  375. useful to specialize the get_basic_credentials() method instead.
  376.  
  377. =cut
  378.  
  379. sub credentials
  380. {
  381.     my($self, $netloc, $realm, $uid, $pass) = @_;
  382.     @{ $self->{'basic_authentication'}{$netloc}{$realm} } = ($uid, $pass);
  383. }
  384.  
  385.  
  386. =item $ua->get_basic_credentials($realm, $uri, [$proxy])
  387.  
  388. This is called by request() to retrieve credentials for a Realm
  389. protected by Basic Authentication or Digest Authentication.
  390.  
  391. Should return username and password in a list.  Return undef to abort
  392. the authentication resolution atempts.
  393.  
  394. This implementation simply checks a set of pre-stored member
  395. variables. Subclasses can override this method to e.g. ask the user
  396. for a username/password.  An example of this can be found in
  397. C<lwp-request> program distributed with this library.
  398.  
  399. =cut
  400.  
  401. sub get_basic_credentials
  402. {
  403.     my($self, $realm, $uri, $proxy) = @_;
  404.     return if $proxy;
  405.  
  406.     my $host_port = $uri->host_port;
  407.     if (exists $self->{'basic_authentication'}{$host_port}{$realm}) {
  408.     return @{ $self->{'basic_authentication'}{$host_port}{$realm} };
  409.     }
  410.  
  411.     return (undef, undef);
  412. }
  413.  
  414.  
  415. =item $ua->agent([$product_id])
  416.  
  417. Get/set the product token that is used to identify the user agent on
  418. the network.  The agent value is sent as the "User-Agent" header in
  419. the requests. The default agent name is "libwww-perl/#.##", where
  420. "#.##" is substitued with the version numer of this library.
  421.  
  422. The user agent string should be one or more simple product identifiers
  423. with an optional version number separated by the "/" character.
  424. Examples are:
  425.  
  426.   $ua->agent('Checkbot/0.4 ' . $ua->agent);
  427.   $ua->agent('Mozilla/5.0');
  428.  
  429. =item $ua->from([$email_address])
  430.  
  431. Get/set the Internet e-mail address for the human user who controls
  432. the requesting user agent.  The address should be machine-usable, as
  433. defined in RFC 822.  The from value is send as the "From" header in
  434. the requests.  There is no default.  Example:
  435.  
  436.   $ua->from('aas@sn.no');
  437.  
  438. =item $ua->timeout([$secs])
  439.  
  440. Get/set the timeout value in seconds. The default timeout() value is
  441. 180 seconds, i.e. 3 minutes.
  442.  
  443. =item $ua->cookie_jar([$cookies])
  444.  
  445. Get/set the I<HTTP::Cookies> object to use.  The default is to have no
  446. cookie_jar, i.e. never automatically add "Cookie" headers to the
  447. requests.
  448.  
  449. =item $ua->parse_head([$boolean])
  450.  
  451. Get/set a value indicating wether we should initialize response
  452. headers from the E<lt>head> section of HTML documents. The default is
  453. TRUE.  Do not turn this off, unless you know what you are doing.
  454.  
  455. =item $ua->max_size([$bytes])
  456.  
  457. Get/set the size limit for response content.  The default is undef,
  458. which means that there is no limit.  If the returned response content
  459. is only partial, because the size limit was exceeded, then a
  460. "X-Content-Range" header will be added to the response.
  461.  
  462. =cut
  463.  
  464. sub timeout    { shift->_elem('timeout',   @_); }
  465. sub agent      { shift->_elem('agent',     @_); }
  466. sub from       { shift->_elem('from',      @_); }
  467. sub cookie_jar { shift->_elem('cookie_jar',@_); }
  468. sub parse_head { shift->_elem('parse_head',@_); }
  469. sub max_size   { shift->_elem('max_size',  @_); }
  470.  
  471. # depreciated
  472. sub use_eval   { shift->_elem('use_eval',  @_); }
  473. sub use_alarm
  474. {
  475.     Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
  476.     if @_ > 1 && $^W;
  477.     "";
  478. }
  479.  
  480.  
  481. =item $ua->clone;
  482.  
  483. Returns a copy of the LWP::UserAgent object
  484.  
  485. =cut
  486.  
  487.  
  488. sub clone
  489. {
  490.     my $self = shift;
  491.     my $copy = bless { %$self }, ref $self;  # copy most fields
  492.  
  493.     # elements that are references must be handled in a special way
  494.     $copy->{'no_proxy'} = [ @{$self->{'no_proxy'}} ];  # copy array
  495.  
  496.     $copy;
  497. }
  498.  
  499.  
  500. =item $ua->is_protocol_supported($scheme)
  501.  
  502. You can use this method to query if the library currently support the
  503. specified C<scheme>.  The C<scheme> might be a string (like 'http' or
  504. 'ftp') or it might be an URI object reference.
  505.  
  506. =cut
  507.  
  508. sub is_protocol_supported
  509. {
  510.     my($self, $scheme) = @_;
  511.     if (ref $scheme) {
  512.     # assume we got a reference to an URI object
  513.     $scheme = $scheme->scheme;
  514.     } else {
  515.     Carp::croak("Illeal scheme '$scheme' passed to is_protocol_supported")
  516.         if $scheme =~ /\W/;
  517.     $scheme = lc $scheme;
  518.     }
  519.     local($SIG{__DIE__});  # protect agains user defined die handlers
  520.     return LWP::Protocol::implementor($scheme);
  521. }
  522.  
  523.  
  524. =item $ua->mirror($url, $file)
  525.  
  526. Get and store a document identified by a URL, using If-Modified-Since,
  527. and checking of the Content-Length.  Returns a reference to the
  528. response object.
  529.  
  530. =cut
  531.  
  532. sub mirror
  533. {
  534.     my($self, $url, $file) = @_;
  535.  
  536.     LWP::Debug::trace('()');
  537.     my $request = new HTTP::Request('GET', $url);
  538.  
  539.     if (-e $file) {
  540.     my($mtime) = (stat($file))[9];
  541.     if($mtime) {
  542.         $request->header('If-Modified-Since' =>
  543.                  HTTP::Date::time2str($mtime));
  544.     }
  545.     }
  546.     my $tmpfile = "$file-$$";
  547.  
  548.     my $response = $self->request($request, $tmpfile);
  549.     if ($response->is_success) {
  550.  
  551.     my $file_length = (stat($tmpfile))[7];
  552.     my($content_length) = $response->header('Content-length');
  553.  
  554.     if (defined $content_length and $file_length < $content_length) {
  555.         unlink($tmpfile);
  556.         die "Transfer truncated: " .
  557.         "only $file_length out of $content_length bytes received\n";
  558.     } elsif (defined $content_length and $file_length > $content_length) {
  559.         unlink($tmpfile);
  560.         die "Content-length mismatch: " .
  561.         "expected $content_length bytes, got $file_length\n";
  562.     } else {
  563.         # OK
  564.         if (-e $file) {
  565.         # Some dosish systems fail to rename if the target exists
  566.         chmod 0777, $file;
  567.         unlink $file;
  568.         }
  569.         rename($tmpfile, $file) or
  570.         die "Cannot rename '$tmpfile' to '$file': $!\n";
  571.  
  572.         if (my $lm = $response->last_modified) {
  573.         # make sure the file has the same last modification time
  574.         utime $lm, $lm, $file;
  575.         }
  576.     }
  577.     } else {
  578.     unlink($tmpfile);
  579.     }
  580.     return $response;
  581. }
  582.  
  583. =item $ua->proxy(...)
  584.  
  585. Set/retrieve proxy URL for a scheme:
  586.  
  587.  $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');
  588.  $ua->proxy('gopher', 'http://proxy.sn.no:8001/');
  589.  
  590. The first form specifies that the URL is to be used for proxying of
  591. access methods listed in the list in the first method argument,
  592. i.e. 'http' and 'ftp'.
  593.  
  594. The second form shows a shorthand form for specifying
  595. proxy URL for a single access scheme.
  596.  
  597. =cut
  598.  
  599. sub proxy
  600. {
  601.     my($self, $key, $proxy) = @_;
  602.  
  603.     LWP::Debug::trace("$key, $proxy");
  604.  
  605.     if (!ref($key)) {   # single scalar passed
  606.     my $old = $self->{'proxy'}{$key};
  607.     $self->{'proxy'}{$key} = $proxy;
  608.     return $old;
  609.     } elsif (ref($key) eq 'ARRAY') {
  610.     for(@$key) {    # array passed
  611.         $self->{'proxy'}{$_} = $proxy;
  612.     }
  613.     }
  614.     return undef;
  615. }
  616.  
  617. =item $ua->env_proxy()
  618.  
  619. Load proxy settings from *_proxy environment variables.  You might
  620. specify proxies like this (sh-syntax):
  621.  
  622.   gopher_proxy=http://proxy.my.place/
  623.   wais_proxy=http://proxy.my.place/
  624.   no_proxy="my.place"
  625.   export gopher_proxy wais_proxy no_proxy
  626.  
  627. Csh or tcsh users should use the C<setenv> command to define these
  628. envirionment variables.
  629.  
  630. =cut
  631.  
  632. sub env_proxy {
  633.     my ($self) = @_;
  634.     my($k,$v);
  635.     while(($k, $v) = each %ENV) {
  636.     $k = lc($k);
  637.     next unless $k =~ /^(.*)_proxy$/;
  638.     $k = $1;
  639.     if ($k eq 'no') {
  640.         $self->no_proxy(split(/\s*,\s*/, $v));
  641.     }
  642.     else {
  643.         $self->proxy($k, $v);
  644.     }
  645.     }
  646. }
  647.  
  648. =item $ua->no_proxy($domain,...)
  649.  
  650. Do not proxy requests to the given domains.  Calling no_proxy without
  651. any domains clears the list of domains. Eg:
  652.  
  653.  $ua->no_proxy('localhost', 'no', ...);
  654.  
  655. =cut
  656.  
  657. sub no_proxy {
  658.     my($self, @no) = @_;
  659.     if (@no) {
  660.     push(@{ $self->{'no_proxy'} }, @no);
  661.     }
  662.     else {
  663.     $self->{'no_proxy'} = [];
  664.     }
  665. }
  666.  
  667.  
  668. # Private method which returns the URL of the Proxy configured for this
  669. # URL, or undefined if none is configured.
  670. sub _need_proxy
  671. {
  672.     my($self, $url) = @_;
  673.     $url = $HTTP::URI_CLASS->new($url) unless ref $url;
  674.  
  675.     my $scheme = $url->scheme || return;
  676.     if (my $proxy = $self->{'proxy'}{$scheme}) {
  677.     if (@{ $self->{'no_proxy'} }) {
  678.         if (my $host = eval { $url->host }) {
  679.         for my $domain (@{ $self->{'no_proxy'} }) {
  680.             if ($host =~ /\Q$domain\E$/) {
  681.             LWP::Debug::trace("no_proxy configured");
  682.             return;
  683.             }
  684.         }
  685.         }
  686.     }
  687.     LWP::Debug::debug("Proxied to $proxy");
  688.     return $HTTP::URI_CLASS->new($proxy);
  689.     }
  690.     LWP::Debug::debug('Not proxied');
  691.     undef;
  692. }
  693.  
  694. 1;
  695.  
  696. =back
  697.  
  698. =head1 SEE ALSO
  699.  
  700. See L<LWP> for a complete overview of libwww-perl5.  See F<lwp-request> and
  701. F<lwp-mirror> for examples of usage.
  702.  
  703. =head1 COPYRIGHT
  704.  
  705. Copyright 1995-1998 Gisle Aas.
  706.  
  707. This library is free software; you can redistribute it and/or
  708. modify it under the same terms as Perl itself.
  709.  
  710. =cut
  711.