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