On Wed, 17 Oct 2001, Doug MacEachern wrote:
> On Wed, 17 Oct 2001, Stas Bekman wrote:
>
> > looks good, but it's quite big for copy-n-pasteing into each test that
> > needs this functionality and quite a few tests may want to use it. Do
> > you think it'd be a good idea to somehow move this into the core
> > functionality?
>
> sure, i just hacked together a proof-of-concept. if that concept works
> for you, feel free to polish it into something more generally usable.
OK, here is the generalization of your proof-of-concept. Note that I've
created a new test pair instead of patching the existing one so it'll be
easier to see what happens, since there is not much left from the existing
one. Once everything is dandy I'll override the existing modperl/interp
test.
this patch:
- allows test files to get their requests served always by the same
interpreter, by abstracting the existing t/modperl/interp.t
- rewrites t/modperl/interp.t to use this new functionality in an
abstracted form
issues:
- I know that I've placed correctly the fixup part (in
Apache::TestHandler), I'm not sure about the two subs I've placed in
Apache::TestRequest, but it seems to be the right place.
- It'd be nice to may be add a :common tag for Apache::TestRequest
exports, since now I've added @EXPORT_OK and if I want something from
@EXPORT_OK, I have to explicitly pull the tags from @EXPORT.
Index: Apache-Test/lib/Apache/TestHandler.pm
===================================================================
RCS file: /home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/TestHandler.pm,v
retrieving revision 1.1
diff -u -r1.1 TestHandler.pm
--- Apache-Test/lib/Apache/TestHandler.pm 2001/04/02 09:00:28 1.1
+++ Apache-Test/lib/Apache/TestHandler.pm 2001/10/18 10:57:28
@@ -1,7 +1,13 @@
package Apache::TestHandler;
+use strict;
+use warnings FATAL => 'all';
+
use Apache::Test ();
+
+use Apache::Const -compile => qw(OK NOT_FOUND SERVER_ERROR);
+
#some utility handlers for testing hooks other than response
#see modperl-2.0/t/hooks/TestHooks/authen.pm
@@ -24,4 +30,55 @@
0;
}
+# a fixup handler to be used when a few requests need to be run
+# against the same perl interpreter, in situations where there is more
+# than one client running. For an example of use see
+# modperl-2.0/t/response/TestModperl/interp.pm and
+# modperl-2.0/t/modperl/interp.t
+#
+# this handler expects the header X-PerlInterpreter in the request
+# - if none is set, Apache::SERVER_ERROR is returned
+# - if its value eq 'tie', instance's global UUID is assigned and
+# returned via the same header
+# - otherwise if its value is not the same the stored instance's
+# global UUID Apache::NOT_FOUND is returned
+#
+# in addition $same_pi_counter counts how many times this instance of
+# pi has been called after the reset 'tie' request (inclusive), this
+# value can be retrieved with Apache::TestHandler::same_pi_counter()
+use constant INTERP => 'X-PerlInterpreter';
+my $same_pi_id = "";
+# keep track of how many times this instance was called after the reset
+my $same_pi_counter = 0;
+sub same_pi_counter { $same_pi_counter }
+sub same_pi_fixup {
+ my $r = shift;
+ my $interp = $r->headers_in->get(INTERP);
+
+ unless ($interp) {
+ # shouldn't be requesting this without an INTERP header
+ return Apache::SERVER_ERROR;
+ }
+
+ my $id = $same_pi_id;
+ if ($interp eq 'tie') { #first request for an interpreter instance
+ # unique id for this instance
+ require APR::UUID;
+ $same_pi_id = $id = APR::UUID->new->format;
+ $same_pi_counter = 0; #reset the counter
+ }
+ elsif ($interp ne $same_pi_id) {
+ # this is not the request interpreter instance
+ return Apache::NOT_FOUND;
+ }
+
+ $same_pi_counter++;
+
+ #so client can save the created instance id or check the existing value
+ $r->headers_out->set(INTERP, $id);
+
+ return Apache::OK;
+}
+
1;
+__END__
Index: Apache-Test/lib/Apache/TestRequest.pm
===================================================================
RCS file: /home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/TestRequest.pm,v
retrieving revision 1.45
diff -u -r1.45 TestRequest.pm
--- Apache-Test/lib/Apache/TestRequest.pm 2001/10/16 20:30:57 1.45
+++ Apache-Test/lib/Apache/TestRequest.pm 2001/10/18 10:57:28
@@ -8,6 +8,9 @@
use Apache::Test ();
use Apache::TestConfig ();
+use constant TRY_TIMES => 50;
+use constant INTERP => 'X-PerlInterpreter';
+
my $have_lwp = eval {
require LWP::UserAgent;
require HTTP::Request::Common;
@@ -37,11 +40,12 @@
};
}
-use vars qw(@EXPORT @ISA $RedirectOK $DebugLWP);
+use vars qw(@EXPORT @EXPORT_OK @ISA $RedirectOK $DebugLWP);
require Exporter;
*import = \&Exporter::import;
@EXPORT = @HTTP::Request::Common::EXPORT;
+@EXPORT_OK = qw(same_pi_tie same_pi_do);
@ISA = qw(LWP::UserAgent);
@@ -401,6 +405,52 @@
my $obj = shift;
ref($obj) ? $obj->as_string : $obj;
}
+
+
+# request an interpreter instance and use this interpreter id to
+# select the same interpreter in requests below
+sub same_pi_tie {
+ my($url) = @_;
+
+ my $res = GET($url, INTERP, 'tie');
+
+ my $pi = $res->header(INTERP);
+
+ return $pi;
+}
+
+# run the request though the selected perl interpreter, by polling
+# until we found it
+# currently supports only GET, HEAD, PUT, POST subs
+sub same_pi_do {
+ my($pi, $sub, $url, @args) = @_;
+ push @args, (INTERP, $pi);
+
+ my $res = '';
+ my $times = 0;
+ my $found_pi = '';
+
+ do {
+ #loop until we get a response from our interpreter instance
+ $res = $sub->($url, @args);
+
+ if ($res->code == 200) {
+ $found_pi = $res->header(INTERP);
+ }
+
+ unless ($found_pi eq $pi) {
+ warn "found wrong pi: $found_pi";
+ $found_pi = '';
+ }
+
+ if ($times++ > TRY_TIMES) { #prevent endless loop
+ die "unable to find interp $pi\n";
+ }
+ } until ($found_pi);
+
+ return $found_pi ? $res : undef;
+}
+
sub set_client_cert {
my $name = shift;
--- /dev/null Thu Jan 1 07:30:00 1970
+++ t/response/TestModperl/interp1.pm Thu Oct 18 18:49:37 2001
@@ -0,0 +1,22 @@
+package TestModperl::interp1;
+
+use warnings FATAL => 'all';
+use strict;
+
+use Apache::Const -compile => qw(OK);
+
+my $value = '';
+
+sub handler {
+ my $r = shift;
+
+ # test the actual global data
+ $value = Apache::TestHandler::same_pi_counter();
+ $r->puts($value);
+
+ Apache::OK;
+}
+
+1;
+__END__
+PerlFixupHandler Apache::TestHandler::same_pi_fixup
--- /dev/null Thu Jan 1 07:30:00 1970
+++ t/modperl/interp1.t Thu Oct 18 18:59:20 2001
@@ -0,0 +1,62 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestUtil;
+use Apache::TestRequest qw(GET HEAD POST same_pi_tie same_pi_do);
+
+use constant INTERP => 'X-PerlInterpreter';
+
+plan tests => 12, \&have_lwp;
+
+my $url = "/TestModperl::interp1";
+
+# test the tie and re-tie
+for (1..2) {
+ my $pi = same_pi_tie($url);
+ ok $pi;
+
+ my $value = 1;
+ # test GET over the same pi
+ for (1..2) {
+ $value++;
+ my $res = same_pi_do($pi, \&GET, $url, foo => 'bar');
+ ok t_cmp(
+ $value,
+ defined $res && $res->content,
+ "GET over the same pi");
+ }
+}
+
+{
+ # test POST over the same pi
+ my $pi = same_pi_tie($url);
+ ok $pi;
+
+ my $value = 1;
+ for (1..2) {
+ $value++;
+ my $res = same_pi_do($pi, \&POST, $url,
+ [ok=>$_+3], content => "foo");
+ ok t_cmp(
+ $value,
+ defined $res && $res->content,
+ "POST over the same pi");
+ }
+}
+
+{
+ # test HEAD over the same pi
+ my $pi = same_pi_tie($url);
+ ok $pi;
+
+ my $value = 1;
+ for (1..2) {
+ $value++;
+ my $res = same_pi_do($pi, \&HEAD, $url);#, content => "foo");
+ ok t_cmp(
+ $pi,
+ defined $res && $res->header(INTERP),
+ "HEAD over the same pi");
+ }
+}
_____________________________________________________________________
Stas Bekman JAm_pH -- Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide http://perl.apache.org/guide
mailto:[EMAIL PROTECTED] http://ticketmaster.com http://apacheweek.com
http://singlesheaven.com http://perl.apache.org http://perlmonth.com/
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
