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