sub new { my $class = shift; my %args = @_; my $self = { _ua => LWP::Custom->new() }; bless $self, $class; # check for passed args to modify defaults $self->{cookie_dir} = $args{cookie_dir} ? $args{cookie_dir} : '/tmp'; # pretend to be IE6 by default ;-) $self->{agent} = $args{agent} ? $args{agent} : 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0; .NET CLR 1.0.3705)'; # use a 30 secont timout by default $self->{timeout} = $args{timeout} ? $args{timeout} : 30; # meta refresh threshold $self->{meta_threshold} = $args{meta_threshold} ? $args{meta_threshold} : 15; # support cookies, first make a unique cookie file for this instance my ( $fh, $name ) = get_tempfile ( $self->{cookie_dir}, 'cookie' ); # as we have created the file we need to make it look like a cookie file # so that LWP does not winge about the missing header print $fh "#LWP-Cookies-1.0\n"; close $fh; $self->{cookie_file} = "$self->{cookie_dir}/$name"; # set up the cookie jar $self->{_cookie_jar} = HTTP::Cookies->new( file => $self->{cookie_file}, autosave => 0, ignore_discard => 1 ); $self->{_cookie_jar}->load( $self->{cookie_file} ); $self->{_ua}->agent( $self->{agent} ); $self->{_ua}->timeout( $self->{timeout} ); return $self; } # this is the simplified guts of the fetch method: my $request = HTTP::Request->new( $method, $url ); # this call can choke, an example is shopping.aol.co.uk which meta # refreshes to aol://1722:ukshopping causing this call to explode eval{$self->{_cookie_jar}->add_cookie_header($request)}; my $response = $self->{_ua}->request($request); $self->{_cookie_jar}->extract_cookies($response); $self->{_cookie_jar}->save( $self->{cookie_file} ); $obj->{content} = $response->content; $obj->{code} = $response->code; $obj->{message} = $response->message; $obj->{title} = $response->headers->title; # we customize the LWP::UserAgent class to suit our needs package LWP::Custom; use base 'LWP::UserAgent'; # add a set_basic_credentials method, using a closure to remember { my ( $username, $password ); sub set_basic_credentials{ ( $username, $password ) = @_[1..2] } sub get_basic_credentials{ $username, $password }; }