File Coverage

blib/lib/Finance/Quote/UserAgent.pm
Criterion Covered Total %
statement 12 33 36.3
branch 0 4 0.0
condition n/a
subroutine 4 11 36.3
pod 5 5 100.0
total 21 53 39.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2             #
3             # Copyright (C) 2000, Paul Fenwick <pjf@cpan.org>
4             #
5             # This program is free software; you can redistribute it and/or modify
6             # it under the terms of the GNU General Public License as published by
7             # the Free Software Foundation; either version 2 of the License, or
8             # (at your option) any later version.
9             #
10             # This program is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13             # GNU General Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License
16             # along with this program; if not, write to the Free Software
17             # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
18             # 02110-1301, USA
19             #
20             # This module defines our own LWP::UserAgent, in particular it allows
21             # user-defined headers to be set which will be automatically added to
22             # new HTTP requests. This is particularly important if you wish to get
23             # through authenticated proxies and the like.
24              
25             package Finance::Quote::UserAgent;
26             require 5.005;
27              
28 62     62   436 use strict;
  62         127  
  62         2047  
29 62     62   45880 use LWP::UserAgent;
  62         3373309  
  62         2418  
30 62     62   612 use HTTP::Headers;
  62         158  
  62         1730  
31              
32 62     62   371 use vars qw/@ISA /;
  62         184  
  62         25048  
33              
34             our $VERSION = '1.58_01'; # TRIAL VERSION
35             @ISA = qw/LWP::UserAgent/;
36              
37             # A very simple extension. When we generate a LWP::UserAgent object,
38             # we add an extra field called finance_quote_headers which stores an
39             # HTTP::Headers object.
40              
41             sub new {
42 0     0 1   my $ua = LWP::UserAgent::new(@_);
43 0           $ua->{finance_quote_headers} = HTTP::Headers->new();
44 0           return $ua;
45             }
46              
47             # This returns the HTTP::Headers object, so the user can play with it.
48             sub default_headers {
49 0     0 1   my $this = shift;
50 0           return $this->{finance_quote_headers};
51             }
52              
53             # Over-ride for the simple_request method. This sets the user-supplied
54             # template headers if they have not already been set in the request.
55             sub simple_request {
56 0     0 1   my ($this, $request, @args) = @_;
57 0           my $new_request = $this->_add_custom_headers($request);
58 0           return $this->SUPER::simple_request($new_request,@args);
59             }
60              
61             # Over-ride for the request method. This also sets the user-supplied
62             # template headers if they have not already been set in the request.
63             sub request {
64 0     0 1   my ($this, $request, @args) = @_;
65 0           my $new_request = $this->_add_custom_headers($request);
66 0           return $this->SUPER::request($new_request,@args);
67             }
68              
69             # _add_custom_headers is a private method which does the dirty work
70             # of copying across headers and other fun things.
71             #
72             # We take the user-defined template, and then overlay the request over the
73             # top of it. This should get us by in most situations.
74              
75             sub _add_custom_headers {
76 0     0     my ($this, $request) = @_;
77 0           my $header_template = $this->default_headers;
78 0           my $new_request = $request->clone; # Modifying the original is rude.
79              
80             # Copy things that are in the template that we don't have
81             # defined in the request.
82              
83             $header_template->scan(sub {
84 0 0   0     $new_request->header($_[0],$_[1]) unless
85             defined ($new_request->header($_[0]));
86 0           });
87              
88 0           return $new_request;
89             }
90              
91             # If users wish to place their username and proxy password(!) into
92             # the "http_proxy_auth_clear" environment variable, then we'll
93             # read it out and automatically use it for proxy requests.
94              
95             sub env_proxy {
96 0     0 1   my ($this, @args) = @_;
97 0 0         if ($ENV{http_proxy_auth_clear}) {
98             $this->default_headers->proxy_authorization_basic(
99 0           split(/:/,$ENV{http_proxy_auth_clear}));
100             }
101 0           $this->SUPER::env_proxy(@_);
102             }
103              
104             1;