the issue here isn't related to the new hook, but rather my use of setting the return status based on $r->args - I think $port was getting assigned the PV value and mod_perl isn't getting the associated IV. int() was just my workaround.
confirmed via Devel::Peek.
but yes, it's somewhat of a real issue (though apparently not, if nobody has reported it yet).
I'll do some investigation and see it I can't fix it for everyone.
attached is a first pass at fixing the problem, coupled with the removal of rc guessing that was already +1'd.
the fix involved checking for both SvIOK and SvPOK. in the case of SvIOK we call SvIVX directly (no need for SvIVx, since we're already IOK) and return the int. if SvPOK we call SvIVx to coerce the string to an integer and return that.
of course, neither of these protects against 'return "foo"', but I didn't see an easy way to trap that and I don't see that as a big issue, as strings were getting translated to OK already.
however, I'm especially interested if SvIV coerces all strings into 0 on all platforms, as I specifically test for that. if not, we can just remove that test.
as for the rest, the return status of the callback is passed directly back to apache. the only exception are handlers with no return status, such as ModPerl::Util::exit, which gets translated as OK.
for the most part, I like the behavior. the only thing that bothers me is whether or not to treat 1 as special, but then we get into the guessing game again, and I'd rather enforce good API use (all handlers ought to return a valid status) over trickery. so we throw a meaningful error message there and leave it to the user to fix.
anyway, feedback welcome.
--Geoff
Index: src/modules/perl/modperl_callback.c
===================================================================
RCS file: /home/cvspublic/modperl-2.0/src/modules/perl/modperl_callback.c,v
retrieving revision 1.61
diff -u -r1.61 modperl_callback.c
--- src/modules/perl/modperl_callback.c 7 Oct 2003 19:16:13 -0000 1.61
+++ src/modules/perl/modperl_callback.c 8 Oct 2003 18:47:43 -0000
@@ -4,6 +4,7 @@
request_rec *r, server_rec *s, AV *args)
{
CV *cv=Nullcv;
+ SV *status_sv;
I32 flags = G_EVAL|G_SCALAR;
dSP;
int count, status = OK;
@@ -71,32 +72,48 @@
SPAGAIN;
if (count != 1) {
+ /* XXX can this really happen with G_SCALAR? */
+ MP_TRACE_h(MP_FUNC, "callback count not 1 - assuming OK\n");
status = OK;
}
else {
- SV* status_sv = POPs;
+ status_sv = POPs;
+
if (SvIOK(status_sv)) {
- status = (IV)SvIVx(status_sv);
+ status = SvIVX(status_sv);
+ MP_TRACE_h(MP_FUNC, "callback returned valid integer status %d\n",
+ status);
}
- else {
- /* ModPerl::Util::exit doesn't return an integer value */
- status = OK;
+ else if (SvPOK(status_sv)) {
+ status = SvIVx(status_sv);
+ MP_TRACE_h(MP_FUNC, "coerced callback return status to integer %d\n",
+ status);
}
- /* assume OK for 200 (HTTP_OK) */
- if ((status == 200)) {
+ else {
+ /* ModPerl::Util::exit() and other void functions.
+ * also routines that die()d, which are caught by ERRSV */
+ MP_TRACE_h(MP_FUNC, "callback IV and PV return slots empty - assuming
OK\n");
status = OK;
}
+
+ /* XXX special error logging for possible Perl gotcha */
+ if (status == 1) {
+ ap_log_error(APLOG_MARK, APLOG_ERR, 0, s,
+ "Perl callback returned 1 - did you forget to return
Apache::OK?\n");
+ }
}
PUTBACK;
}
-
+
FREETMPS;LEAVE;
if (SvTRUE(ERRSV)) {
MP_TRACE_h(MP_FUNC, "$@ = %s", SvPVX(ERRSV));
status = HTTP_INTERNAL_SERVER_ERROR;
}
+
+ MP_TRACE_h(MP_FUNC, "returning %d from callback\n", status);
return status;
}
Index: t/response/TestModperl/current_callback.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/t/response/TestModperl/current_callback.pm,v
retrieving revision 1.3
diff -u -r1.3 current_callback.pm
--- t/response/TestModperl/current_callback.pm 31 Mar 2003 01:50:52 -0000 1.3
+++ t/response/TestModperl/current_callback.pm 8 Oct 2003 18:47:43 -0000
@@ -36,6 +36,8 @@
die "expecting $expected callback, instead got $callback"
unless $callback eq $expected;
#warn "in callback: $callback\n";
+
+ return Apache::OK;
}
1;
--- /dev/null 2003-01-30 05:24:37.000000000 -0500
+++ t/modperl/status.t 2003-10-08 14:34:14.000000000 -0400
@@ -0,0 +1,145 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestRequest;
+use Apache::TestUtil qw(t_cmp t_server_log_error_is_expected);
+
+use Apache2;
+use Apache::Const -compile => qw(OK DECLINED
+ NOT_FOUND SERVER_ERROR FORBIDDEN
+ HTTP_OK);
+
+plan tests => 13;
+
+my $base = '/TestModperl__status';
+
+# valid Apache return codes
+{
+ my $uri = join '?', $base, Apache::OK;
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::HTTP_OK,
+ $code,
+ $uri);
+}
+
+{
+ my $uri = join '?', $base, Apache::DECLINED;
+ my $code = GET_RC $uri;
+
+ # no Alias to map us to DocumentRoot
+ ok t_cmp(Apache::NOT_FOUND,
+ $code,
+ $uri);
+}
+
+# 200 is treated as an error, since it's not
+# OK, DECLINED, or DONE. while apache's lookups
+# succeed so the 200 is propagated to the client
+# there's an error beneath that 200 code.
+{
+ my $uri = join '?', $base, Apache::HTTP_OK;
+ my $response = GET $uri;
+
+ ok t_cmp(Apache::HTTP_OK,
+ $response->code,
+ $uri);
+
+ ok t_cmp(qr/server encountered an internal error/,
+ $response->content,
+ $uri);
+}
+
+# standard HTTP status codes
+{
+ my $uri = join '?', $base, Apache::NOT_FOUND;
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::NOT_FOUND,
+ $code,
+ $uri);
+}
+
+{
+ my $uri = join '?', $base, Apache::FORBIDDEN;
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::FORBIDDEN,
+ $code,
+ $uri);
+}
+
+{
+ my $uri = join '?', $base, Apache::SERVER_ERROR;
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::SERVER_ERROR,
+ $code,
+ $uri);
+}
+
+# apache translates non-HTTP codes into 500
+# see ap_index_of_response
+{
+ my $uri = join '?', $base, 614;
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::SERVER_ERROR,
+ $code,
+ $uri);
+}
+
+{
+ my $uri = join '?', $base, 313;
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::SERVER_ERROR,
+ $code,
+ $uri);
+}
+
+# mod_perl-specific implementation tests
+{
+ # ModPerl::Util::exit - voids return OK
+ my $uri = join '?', $base, 'exit';
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::HTTP_OK,
+ $code,
+ $uri);
+}
+
+{
+ # die gets trapped
+ my $uri = join '?', $base, 'die';
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::SERVER_ERROR,
+ $code,
+ $uri);
+}
+
+{
+ # sv_2iv turns real strings into 0, which is Apache::OK
+ # XXX on all platforms? all perl versions?
+ my $uri = join '?', $base, 'foo';
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::HTTP_OK,
+ $code,
+ $uri);
+}
+
+{
+ # 1 is special in perl, generally meaning the
+ # last statement executed successfully - eg
+ # sub handler { print "foo" }
+ my $uri = join '?', $base, 1;
+ my $code = GET_RC $uri;
+
+ ok t_cmp(Apache::SERVER_ERROR,
+ $code,
+ $uri);
+}
+
--- /dev/null 2003-01-30 05:24:37.000000000 -0500
+++ t/response/TestModperl/status.pm 2003-10-08 14:38:38.000000000 -0400
@@ -0,0 +1,29 @@
+package TestModperl::status;
+
+use Apache::RequestRec;
+use Apache::Const -compile => qw(DECLINED);
+
+use ModPerl::Util;
+use Apache::TestUtil qw(t_server_log_error_is_expected);
+
+sub handler {
+
+ my $rc = shift->args;
+
+ if ($rc eq 'die' ||
+ $rc == Apache::DECLINED ||
+ $rc == 1) {
+ t_server_log_error_is_expected();
+ }
+
+ ModPerl::Util::exit if $rc eq 'exit';
+
+ die if $rc eq 'die';
+
+ return $rc;
+}
+
+1;
+__END__
+
+
--------------------------------------------------------------------- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED]
