view release on metacpan or  search on metacpan

Server/t/lib/Apache/test.pm  view on Meta::CPAN

sub test { 
    shift() if UNIVERSAL::isa($_[0], __PACKAGE__);
    my $s = $_[1] ? "ok $_[0]\n" : "not ok $_[0]\n";
    if($ENV{MOD_PERL}) {
	Apache->request->print($s);
    }
    else {
	print $s;
    }
}

sub fetch {
    # Old code calls fetch() as a function, new code as a method
    my $want_response;
    $want_response = shift() if UNIVERSAL::isa($_[0], __PACKAGE__);
    my ($ua, $url) = (@_ == 1 ? ($UA, shift()) : @_);
    my $request = ref $url ? $url : {uri=>$url};

    # Set some defaults
    $ENV{PORT} ||= 8529;  # For mod_perl's own tests
    $request->{method} ||= 'GET';
    $request->{content} = '' unless exists $request->{content};
    $request->{uri} = "http://localhost:$ENV{PORT}$request->{uri}"    
	unless $request->{uri} =~ /^http/;
    $request->{headers}{Content_Type} = 'application/x-www-form-urlencoded'
	if (!$request->{headers} and $request->{method} eq 'POST');  # Is this necessary?

    # Create & send the request
    $request->{headers} = new HTTP::Headers(%{$request->{headers}||{}});
    my $req = new HTTP::Request(@{$request}{'method','uri','headers','content'});
    my $response = $ua->request($req);

    return $want_response ? $response : $response->content;
}

sub simple_fetch {
    my $ua = LWP::UserAgent->new;
    my $url = URI::URL->new("http://$net::httpserver");
    my($path,$q) = split /\?/, shift; 
    $url->path($path);
    $url->query($q) if $q;
    my $request = new HTTP::Request('GET', $url);
    my $response = $ua->request($request, undef, undef);   
    $response->is_success;
}

#even if eval $mod fails, the .pm ends up in %INC
#so the next eval $mod succeeds, when it shouldnot

my %really_have = (
   'Apache::Table' => sub { 
       if ($ENV{MOD_PERL}) {
	   return Apache::Table->can('TIEHASH');
       }
       else {
	   return $net::callback_hooks{PERL_TABLE_API};
       }
   },
);

for (qw(Apache::Cookie Apache::Request)) {
    $really_have{$_} = $really_have{'Apache::Table'};
}

sub have_module {
    my $mod = shift;
    my $v = shift;
    eval {# surpress "can't boostrap" warnings
	 local $SIG{__WARN__} = sub {};
	 require Apache;
	 require Apache::Constants;
    };

    eval "require $mod";
    if($v and not $@) {
	eval { 
	    local $SIG{__WARN__} = sub {};
	    $mod->UNIVERSAL::VERSION($v);
	};
	if($@) {
	    warn $@;
	    return 0;
	}
    }
    if($@ && ($@ =~ /Can.t locate/)) {
	return 0;
    }
    elsif($@ && ($@ =~ /Can.t find loadable object for module/)) {
	return 0;
    }
    elsif($@) {
	warn "$@\n";
    }

    if (my $cv = $really_have{$mod}) {
	return 0 unless $cv->();
    }

    print "module $mod is installed\n" unless $ENV{MOD_PERL};
    
    return 1;
}

sub skip_test {
    print "1..0\n";
    exit;
}

sub have_httpd {
    return -e 't/httpd';
}

sub run {
    require Test::Harness;
    my $self = shift;
    my $args = shift || {};
    my @tests = ();

    # First we check if we already are within the "t" directory
    if (-d "t") {
	# try to move into test directory

Server/t/lib/Apache/test.pm  view on Meta::CPAN

=head2 fetch

  Apache::test->fetch($request);
  Apache::test->fetch($user_agent, $request);

Call this method in a test script in order to fetch a page from the
running web server.  If you pass two arguments, the first should be an
LWP::UserAgent object, and the second should specify the request to
make of the server.  If you only pass one argument, it specifies the
request to make.

The request can be specified either by a simple string indicating the
URI to fetch, or by a hash reference, which gives you more control
over the request.  The following keys are recognized in the hash:

=over 4

=item * uri

The URI to fetch from the server.  If the URI does not begin with
"http", we prepend "http://localhost:$PORT" so that we make requests
of the test server.

=item * method

The request method to use.  Default is 'GET'.

=item * content

The request content body.  Typically used to simulate HTML fill-out
form submission for POST requests.  Default is null.

=item * headers

A hash of headers you want sent with the request.  You might use this
to send cookies or provide some application-specific header.

=back

If you don't provide a 'headers' parameter and you set the 'method'
to 'POST', then we assume that you're trying to simulate HTML form
submission and we add a 'Content_Type' header with a value of
'application/x-www-form-urlencoded'.

In a scalar context, fetch() returns the content of the web server's
response.  In a list context, fetch() returns the content and the
HTTP::Response object itself.  This can be handy if you need to check
the response headers, or the HTTP return code, or whatever.

=head2 static_modules

 Example: $mods = Apache::test->static_modules('/path/to/httpd');

This method returns a hashref whose keys are all the modules
statically compiled into the given httpd binary.  The corresponding
values are all 1.

=head1 EXAMPLES

No good examples yet.  Example submissions are welcome.  In the meantime, see
L<http://forum.swarthmore.edu/~ken/modules/Apache-AuthCookie/> , which
I'm retrofitting to use Apache::test.

=head1 TO DO

The MM_test method doesn't try to be very smart, it just writes the
text that seems to work in my configuration.  I am morally against
using the 'make' command for installing Perl modules (though of course
I do it anyway), so I haven't looked into this very much.  Send bug
reports or better (patches).

I've got lots of code in my Apache::AuthCookie module (etc.) that
assists in actually making the queries of the running server.  I plan
to add that to this module, but first I need to compare what's already
here that does the same stuff.

=head1 KUDOS

To Doug MacEachern for writing the first version of this module.

To caelum@debian.org (Rafael Kitover) for contributing the code to
parse existing httpd.conf files for --enable-shared=max and DSOs.

=head1 CAVEATS

Except for making sure that the mod_perl distribution itself can run
'make test' okay, I haven't tried very hard to keep compatibility with
older versions of this module.  In particular MM_test() has changed
and probably isn't usable in the old ways, since some of its
assumptions are gone.  But none of this was ever documented, and
MM_test() doesn't seem to actually be used anywhere in the mod_perl
disribution, so I don't feel so bad about it.

=head1 AUTHOR

Doug MacEachern (original version)

Ken Williams (latest changes and this documentation)

=cut