dougm 01/04/02 01:55:43 Added: Apache-Test/lib/Apache TestRequest.pm Log: lwp wrappers / fallback for no lwp Revision Changes Path 1.1 modperl-2.0/Apache-Test/lib/Apache/TestRequest.pm Index: TestRequest.pm =================================================================== package Apache::TestRequest; use strict; use warnings FATAL => 'all'; use Apache::TestConfig (); my $have_lwp = eval { require LWP::UserAgent; require HTTP::Request::Common; }; sub has_lwp { $have_lwp } require Exporter; *import = \&Exporter::import; our @EXPORT = @HTTP::Request::Common::EXPORT; our @ISA = qw(LWP::UserAgent); my $UA; my $Config; sub resolve_url { my $url = shift; return $url if $url =~ m,^(\w+):/,; $url = "/$url" unless $url =~ m,^/,; return "http://$Config->{hostport}$url"; } my %wanted_args = map {$_, 1} qw(username password realm content); sub wanted_args { \%wanted_args; } sub filter_args { my $args = shift; my(@pass, %keep); my @filter = @$args; if (ref($filter[0])) { push @pass, shift @filter; } while (my($key, $val) = splice @filter, 0, 2) { if ($wanted_args{$key}) { $keep{$key} = $val; } else { push @pass, $key, $val; } } return (\@pass, \%keep); } my %credentials; sub get_basic_credentials { my($self, $realm, $uri, $proxy) = @_; for ($realm, '__ALL__') { next unless $credentials{$_}; return @{ $credentials{$_} }; } return (undef,undef); } sub test_config { $Config ||= Apache::TestConfig->thaw; } sub vhost_socket { my $module = shift; my $hostport = test_config()->{vhosts}->{$module}->{hostport}; require IO::Socket; IO::Socket::INET->new($hostport); } sub prepare { eval { $UA ||= __PACKAGE__->new; }; $Config ||= test_config(); my $url = resolve_url(shift); my($pass, $keep) = filter_args(\@_); %credentials = (); if ($keep->{username}) { $credentials{$keep->{realm} || '__ALL__'} = [$keep->{username}, $keep->{password}]; } if (my $content = $keep->{content}) { if ($content eq '-') { $content = join '', <STDIN>; } push @$pass, content => $content; } return ($url, $pass, $keep); } my %shortcuts = (RC => sub { shift->code }, OK => sub { shift->is_success }, STR => sub { shift->as_string }, BODY => sub { shift->content }); for my $name (@EXPORT) { my $method = \&{"HTTP::Request::Common::$name"}; no strict 'refs'; *$name = sub { my($url, $pass, $keep) = prepare(@_); return $UA->request($method->($url, @$pass)); }; while (my($shortcut, $cv) = each %shortcuts) { my $alias = join '_', $name, $shortcut; *$alias = sub { (\&{$name})->(@_)->$cv; }; } } my @export_std = @EXPORT; for my $method (@export_std) { push @EXPORT, map { join '_', $method, $_ } keys %shortcuts; } #this is intended to be a fallback if LWP is not installed #so at least some tests can be run, it is not meant to be robust for my $name (qw(GET HEAD)) { next if defined &$name; no strict 'refs'; *$name = sub { return test_config()->http_raw_get(shift, $name); }; } sub http_raw_get { my($hostport, $url, $want_headers) = @_; $url ||= "/"; require IO::Socket; my $s = IO::Socket::INET->new($hostport); unless ($s) { warn "cannot connect to $hostport $!"; return undef; } print $s "GET $url HTTP/1.0\n\n"; my($response_line, $header_term, $headers); $headers = ""; while (<$s>) { $headers .= $_; if(m:^(HTTP/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*):i) { $response_line = 1; } elsif(/^([a-zA-Z0-9_\-]+)\s*:\s*(.*)/) { } elsif(/^\015?\012$/) { $header_term = 1; last; } } unless ($response_line and $header_term) { warn "malformed response"; } my @body = <$s>; close $s; if ($want_headers) { if ($want_headers > 1) { @body = (); #HEAD } unshift @body, $headers; } return wantarray ? @body : join '', @body; } sub to_string { my $obj = shift; ref($obj) ? $obj->as_string : $obj; } 1;