stas 2004/05/03 23:16:46
Modified: t/modperl .cvsignore
ModPerl-Registry/lib/ModPerl RegistryCooker.pm
src/modules/perl modperl_util.c
t/response/TestModperl exit.pm
Added: t/modperl exit.t
Log:
ModPerl::Util::exit now throws an exception object, so it's possible to
rethrow exit if it gets trapped in eval context on the user side
Revision Changes Path
1.16 +0 -1 modperl-2.0/t/modperl/.cvsignore
Index: .cvsignore
===================================================================
RCS file: /home/cvs/modperl-2.0/t/modperl/.cvsignore,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -u -r1.15 -r1.16
--- .cvsignore 18 Feb 2004 00:23:36 -0000 1.15
+++ .cvsignore 4 May 2004 06:16:46 -0000 1.16
@@ -1,7 +1,6 @@
current_callback.t
env.t
endav.t
-exit.t
printf.t
print.t
pnotes.t
1.1 modperl-2.0/t/modperl/exit.t
Index: exit.t
===================================================================
use Apache::TestRequest 'GET_BODY_ASSERT';
use Apache::Test;
use Apache::TestUtil;
my $location = "/TestModperl__exit";
plan tests => 3;
{
ok t_cmp('exited',
GET_BODY_ASSERT("$location?noneval"),
"exit in non eval context");
}
{
my $body = GET_BODY_ASSERT("$location?eval");
ok t_cmp(qr/^ModPerl::Util::exit: exit was called/,
$body,
"exit in eval context");
ok !t_cmp(qr/must not be reached/,
$body,
"exit in eval context");
}
1.47 +5 -4 modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm
Index: RegistryCooker.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -u -r1.46 -r1.47
--- RegistryCooker.pm 2 Apr 2004 02:17:45 -0000 1.46
+++ RegistryCooker.pm 4 May 2004 06:16:46 -0000 1.47
@@ -41,7 +41,8 @@
use File::Spec::Functions ();
use File::Basename;
-use Apache::Const -compile => qw(:common &OPT_EXECCGI);
+use Apache::Const -compile => qw(:common &OPT_EXECCGI);
+use ModPerl::Const -compile => 'EXIT';
unless (defined $ModPerl::Registry::MarkLine) {
$ModPerl::Registry::MarkLine = 1;
@@ -714,10 +715,10 @@
sub error_check {
my $self = shift;
- # ModPerl::Util::exit() is implemented as croak with no message
- # so perl will set $@ to " at /some/path", which is not an error
+ # ModPerl::Util::exit() throws an exception object whose rc is
+ # ModPerl::EXIT
# (see modperl_perl_exit() and modperl_errsv() C functions)
- if ($@ and substr($@, 0, 4) ne " at ") {
+ if ($@ && !(ref $@ && $@ == ModPerl::EXIT)) {
$self->log_error($@);
return Apache::SERVER_ERROR;
}
1.67 +5 -19 modperl-2.0/src/modules/perl/modperl_util.c
Index: modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -u -r1.66 -r1.67
--- modperl_util.c 3 Apr 2004 02:35:47 -0000 1.66
+++ modperl_util.c 4 May 2004 06:16:46 -0000 1.67
@@ -261,25 +261,16 @@
return p;
}
-char *modperl_apr_strerror(apr_status_t rv)
-{
- dTHX;
- char buf[256];
- apr_strerror(rv, buf, sizeof(buf));
- return Perl_form(aTHX_ "%d:%s", rv, buf);
-}
-
int modperl_errsv(pTHX_ int status, request_rec *r, server_rec *s)
{
SV *sv = ERRSV;
STRLEN n_a;
if (SvTRUE(sv)) {
- if (SvMAGICAL(sv) && (SvCUR(sv) > 4) &&
- strnEQ(SvPVX(sv), " at ", 4))
- {
+ if (sv_derived_from(sv, "APR::Error") &&
+ SvIVx(sv) == MODPERL_RC_EXIT) {
/* ModPerl::Util::exit was called */
- return DECLINED;
+ return OK;
}
#if 0
if (modperl_sv_is_http_code(ERRSV, &status)) {
@@ -572,15 +563,10 @@
void modperl_perl_exit(pTHX_ int status)
{
- const char *pat = NULL;
ENTER;
SAVESPTR(PL_diehook);
PL_diehook = Nullsv;
- sv_setpv(ERRSV, "");
-#ifdef MP_PERL_5_6_0
- pat = ""; /* NULL segvs in 5.6.0 */
-#endif
- Perl_croak(aTHX_ pat);
+ modperl_croak(aTHX_ MODPERL_RC_EXIT, "ModPerl::Util::exit");
}
MP_INLINE SV *modperl_dir_config(pTHX_ request_rec *r, server_rec *s,
@@ -716,7 +702,7 @@
if (rc != APR_SUCCESS) { \
SvREFCNT_dec(sv); \
Perl_croak(aTHX_ "Error " action " '%s': %s ", r->filename, \
- modperl_apr_strerror(rc)); \
+ modperl_error_strerror(aTHX_ rc)); \
}
MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
1.3 +24 -9 modperl-2.0/t/response/TestModperl/exit.pm
Index: exit.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestModperl/exit.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -u -r1.2 -r1.3
--- exit.pm 11 Apr 2002 11:08:44 -0000 1.2
+++ exit.pm 4 May 2004 06:16:46 -0000 1.3
@@ -1,25 +1,40 @@
package TestModperl::exit;
+# there is no need to call ModPerl::Util::exit() explicitly, a plain
+# exit() will do. We do the explicit fully qualified call in this
+# test, in case something has messed up with CORE::GLOBAL::exit and we
+# want to make sure that we test the right API
+
use strict;
use warnings FATAL => 'all';
use ModPerl::Util ();
-use Apache::Test;
-
-use Apache::Const -compile => 'OK';
+use Apache::Const -compile => 'OK';
+use ModPerl::Const -compile => 'EXIT';
sub handler {
my $r = shift;
- plan $r, test => 1;
-
- ok 1;
+ $r->content_type('text/plain');
+ my $args = $r->args;
- ModPerl::Util::exit();
+ if ($args eq 'eval') {
+ eval {
+ my $whatever = 1;
+ ModPerl::Util::exit();
+ };
+ # test whether we can stringify our custom error messages
+ $r->print("$@");
+ ModPerl::Util::exit if $@ && ref $@ && $@ == ModPerl::EXIT;
+ }
+ elsif ($args eq 'noneval') {
+ $r->print("exited");
+ ModPerl::Util::exit();
+ }
- #not reached
- ok 2;
+ # must not be reached
+ $r->print("must not be reached");
Apache::OK;
}
