You are viewing a plain text version of this content. The canonical link for it is here.
Posted to dev@perl.apache.org by Stas Bekman <st...@stason.org> on 2004/05/03 03:38:25 UTC
[mp2 patch] exception objects
OK, here is a working implementation of exception objects in mp2 including
tests. This big patch includes:
- infrastructure for ModPerl::Const
- implementation of exception objects + tests
o the throwing part in C
o ModPerl::Error is the class that handles those exception objects
- including a custom confess() function, since Carp::confess doesn't work
- implementation of the $socket->recv using the new simplified API
(no rc code) + tests
- reimplementation of exit using exception objects + tests (now it's possible
to rethrow exit if trapped in eval context (see the tests).
I didn't want to touch it now, so you can review this big change while 'make
test' passes 100%. But I'm going to rename ModPerl::Error and use APR::Error
instead (just a rename, so it's suitable for usage outside mod_perl) and I
need to reimplement APR::strerror to move into APR::Error and support new
error codes introduced by mod_perl.
Comments are welcome. I really want to freeze this and move on fixing the rest
of the (huge!) API.
I'm also going to smoke it tonight and hope that it'll work with various perl
builds.
Question:
- how should we name the defines for exception codes? I did
MODPERL_CONST_EXIT for the EXIT exception. Or should it be MODPERL_ERROR_EXIT
or else?
Index: ModPerl-Registry/lib/ModPerl/RegistryCooker.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm,v
retrieving revision 1.46
diff -u -r1.46 RegistryCooker.pm
--- ModPerl-Registry/lib/ModPerl/RegistryCooker.pm 2 Apr 2004 02:17:45 -0000 1.46
+++ ModPerl-Registry/lib/ModPerl/RegistryCooker.pm 3 May 2004 01:24:44 -0000
@@ -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;
}
Index: lib/Apache/ParseSource.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/Apache/ParseSource.pm,v
retrieving revision 1.53
diff -u -r1.53 ParseSource.pm
--- lib/Apache/ParseSource.pm 1 May 2004 00:15:44 -0000 1.53
+++ lib/Apache/ParseSource.pm 3 May 2004 01:24:45 -0000
@@ -257,6 +257,9 @@
table => [qw{APR_OVERLAP_TABLES_}],
uri => [qw{APR_URI_}],
},
+ ModPerl => {
+ common => [qw{MODPERL_CONST_}],
+ }
);
my %defines_wanted_re;
Index: lib/ModPerl/Code.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/Code.pm,v
retrieving revision 1.120
diff -u -r1.120 Code.pm
--- lib/ModPerl/Code.pm 26 Apr 2004 20:20:01 -0000 1.120
+++ lib/ModPerl/Code.pm 3 May 2004 01:24:45 -0000
@@ -775,7 +775,7 @@
#$self->generate_constants_pod();
}
-my $constant_prefixes = join '|', qw{APR?};
+my $constant_prefixes = join '|', qw{APR? MODPERL_CONST};
sub generate_constants {
my($self, $h_fh, $c_fh) = @_;
@@ -824,6 +824,7 @@
my $postfix = lc $class;
my $package = $class . '::';
my $package_len = length $package;
+ my($first_let) = $class =~ /^(\w)/;
my $func = canon_func(qw(constants lookup), $postfix);
my $proto = "SV \*$func(pTHX_ const char *name)";
@@ -834,7 +835,7 @@
$proto
{
- if (*name == 'A' && strnEQ(name, "$package", $package_len)) {
+ if (*name == '$first_let' && strnEQ(name, "$package", $package_len)) {
name += $package_len;
}
Index: src/modules/perl/mod_perl.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.c,v
retrieving revision 1.212
diff -u -r1.212 mod_perl.c
--- src/modules/perl/mod_perl.c 2 Apr 2004 02:17:45 -0000 1.212
+++ src/modules/perl/mod_perl.c 3 May 2004 01:24:45 -0000
@@ -92,6 +92,8 @@
*/
modperl_require_module(aTHX_ "DynaLoader", FALSE);
+// modperl_require_module(aTHX_ "ModPerl::Error", TRUE);
+
IoFLUSH_on(PL_stderrgv); /* unbuffer STDERR */
}
Index: src/modules/perl/modperl_callback.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_callback.c,v
retrieving revision 1.70
diff -u -r1.70 modperl_callback.c
--- src/modules/perl/modperl_callback.c 4 Mar 2004 06:01:06 -0000 1.70
+++ src/modules/perl/modperl_callback.c 3 May 2004 01:24:46 -0000
@@ -106,7 +106,7 @@
}
else {
SV *status_sv = POPs;
-
+
if (SvIOK(status_sv)) {
/* normal IV return (e.g., Apache::OK) */
status = SvIVX(status_sv);
@@ -121,7 +121,7 @@
status = SvIVx(status_sv);
MP_TRACE_h(MP_FUNC,
"coercing handler %s's return value '%s' into %d",
- handler->name, SvPVX(status_sv), status);
+ handler->name, SvPV_nolen(status_sv), status);
}
else {
/* any other return types are considered as errors */
@@ -131,14 +131,14 @@
handler->name);
}
}
-
+
PUTBACK;
}
FREETMPS;LEAVE;
if (SvTRUE(ERRSV)) {
- MP_TRACE_h(MP_FUNC, "$@ = %s", SvPVX(ERRSV));
+ MP_TRACE_h(MP_FUNC, "$@ = %s", SvPV_nolen(ERRSV));
status = HTTP_INTERNAL_SERVER_ERROR;
}
Index: src/modules/perl/modperl_const.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_const.c,v
retrieving revision 1.11
diff -u -r1.11 modperl_const.c
--- src/modules/perl/modperl_const.c 4 Mar 2004 06:01:07 -0000 1.11
+++ src/modules/perl/modperl_const.c 3 May 2004 01:24:46 -0000
@@ -31,8 +31,8 @@
SV *val = (*lookup)(aTHX_ name);
#if 0
- fprintf(stderr, "newCONSTSUB(%s, %s, %d)\n",
- HvNAME(stash), name, val);
+ Perl_warn(aTHX_ "newCONSTSUB(%s, %s, %s)\n",
+ HvNAME(stash), name, SvPV_nolen(val));
#endif
newCONSTSUB(stash, (char *)name, val);
@@ -67,10 +67,14 @@
lookup = modperl_constants_lookup_apr;
group_lookup = modperl_constants_group_lookup_apr;
}
- else {
+ else if (strnEQ(classname, "Apache", 6)) {
lookup = modperl_constants_lookup_apache;
group_lookup = modperl_constants_group_lookup_apache;
}
+ else {
+ lookup = modperl_constants_lookup_modperl;
+ group_lookup = modperl_constants_group_lookup_modperl;
+ }
if (*arg != '-') {
/* only export into callers namespace without -compile arg */
@@ -111,7 +115,9 @@
Perl_croak(aTHX_ "Usage: %s->compile(...)", stashname);
}
- classname = *(stashname + 1) == 'P' ? "APR" : "Apache";
+ classname = *(stashname + 1) == 'P'
+ ? "APR"
+ : (*stashname == 'A' ? "Apache" : "ModPerl");
arg = SvPV(ST(1),n_a);
for (i=2; i<items; i++) {
Index: src/modules/perl/modperl_const.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_const.h,v
retrieving revision 1.3
diff -u -r1.3 modperl_const.h
--- src/modules/perl/modperl_const.h 4 Mar 2004 06:01:07 -0000 1.3
+++ src/modules/perl/modperl_const.h 3 May 2004 01:24:46 -0000
@@ -29,4 +29,9 @@
CvXSUB(get_cv("ModPerl::Const::compile", TRUE)), \
__FILE__)
+/*** real constants ****/
+
+/* to check whether $@ is set by ModPerl::Util::exit */
+#define MODPERL_CONST_EXIT APR_OS_START_USERERR + 1
+
#endif /* MODPERL_CONST_H */
Index: src/modules/perl/modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.66
diff -u -r1.66 modperl_util.c
--- src/modules/perl/modperl_util.c 3 Apr 2004 02:35:47 -0000 1.66
+++ src/modules/perl/modperl_util.c 3 May 2004 01:24:46 -0000
@@ -269,17 +269,43 @@
return Perl_form(aTHX_ "%d:%s", rv, buf);
}
+/* croak with $@ as a ModPerl::Error object
+ * rc - set to apr_status_t value
+ * file - set to the callers filename
+ * line - set to the callers line number
+ * func - set to the function name
+ */
+void modperl_croak(pTHX_ apr_status_t rc, const char* func)
+{
+ HV *stash;
+ HV *data;
+
+ /* XXX: it'd be nice to arrange for it to load early */
+ modperl_require_module(aTHX_ "ModPerl::Error", TRUE);
+
+ stash = gv_stashpvn("ModPerl::Error", 14, FALSE);
+ data = newHV();
+ /* $@ = bless {}, "ModPerl::Error"; */
+ sv_setsv(ERRSV, sv_bless(newRV_noinc((SV*)data), stash));
+
+ sv_setiv(*hv_fetch(data, "num", 3, 1), rc);
+ sv_setpv(*hv_fetch(data, "file", 4, 1), CopFILE(PL_curcop));
+ sv_setiv(*hv_fetch(data, "line", 4, 1), CopLINE(PL_curcop));
+ sv_setpv(*hv_fetch(data, "func", 4, 1), func);
+
+ Perl_croak(aTHX_ Nullch);
+}
+
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, "ModPerl::Error") &&
+ SvIVx(sv) == MODPERL_CONST_EXIT) {
/* ModPerl::Util::exit was called */
- return DECLINED;
+ return OK;
}
#if 0
if (modperl_sv_is_http_code(ERRSV, &status)) {
@@ -572,15 +598,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_CONST_EXIT, "ModPerl::Util::exit");
}
MP_INLINE SV *modperl_dir_config(pTHX_ request_rec *r, server_rec *s,
Index: src/modules/perl/modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.55
diff -u -r1.55 modperl_util.h
--- src/modules/perl/modperl_util.h 22 Apr 2004 23:14:31 -0000 1.55
+++ src/modules/perl/modperl_util.h 3 May 2004 01:24:46 -0000
@@ -65,6 +65,14 @@
#define MP_magical_tie(sv, mg_flags) \
SvFLAGS((SV*)sv) |= mg_flags
+#define MP_RUN_CROAK(rc_run) STMT_START \
+ apr_status_t rc = rc_run; \
+ if (rc != APR_SUCCESS) { \
+ modperl_croak(aTHX_ rc); \
+ } \
+ STMT_END
+
+// XXX: this should be removed
#define MP_FAILURE_CROAK(rc_run) do { \
apr_status_t rc = rc_run; \
if (rc != APR_SUCCESS) { \
@@ -103,6 +111,8 @@
const char *classname, UV uv);
char *modperl_apr_strerror(apr_status_t rv);
+
+void modperl_croak(pTHX_ apr_status_t rc, const char* func);
int modperl_errsv(pTHX_ int status, request_rec *r, server_rec *s);
Index: t/error/runtime.t
===================================================================
RCS file: /home/cvs/modperl-2.0/t/error/runtime.t,v
retrieving revision 1.2
diff -u -r1.2 runtime.t
--- t/error/runtime.t 18 Apr 2003 06:18:56 -0000 1.2
+++ t/error/runtime.t 3 May 2004 01:24:46 -0000
@@ -5,13 +5,32 @@
use Apache::TestUtil;
use Apache::TestRequest;
-plan tests => 1;
-
my $location = "/TestError__runtime";
-my $res = GET($location);
-#t_debug($res->content);
-ok t_cmp(
- 500,
- $res->code,
- "500 error on runtime error",
+
+my @untrapped = qw(plain_mp_error plain_non_mp_error
+ die_hook_confess_mp_error die_hook_confess_non_mp_error
+ die_hook_custom_mp_error die_hook_custom_non_mp_error);
+my @trapped = qw(eval_block_mp_error eval_block_non_mp_error
+ eval_string_mp_error eval_block_non_error);
+
+plan tests => @untrapped + @trapped;
+
+for my $type (@untrapped) {
+ my $res = GET("$location?$type");
+ #t_debug($res->content);
+ ok t_cmp(
+ 500,
+ $res->code,
+ "500 error on $type exception",
);
+}
+
+for my $type (@trapped) {
+ my $body = GET_BODY("$location?$type");
+ ok t_cmp(
+ "ok $type",
+ $body,
+ "200 on $type exception",
+ );
+}
+
Index: t/modperl/.cvsignore
===================================================================
RCS file: /home/cvs/modperl-2.0/t/modperl/.cvsignore,v
retrieving revision 1.15
diff -u -r1.15 .cvsignore
--- t/modperl/.cvsignore 18 Feb 2004 00:23:36 -0000 1.15
+++ t/modperl/.cvsignore 3 May 2004 01:24:46 -0000
@@ -1,7 +1,6 @@
current_callback.t
env.t
endav.t
-exit.t
printf.t
print.t
pnotes.t
Index: t/protocol/TestProtocol/echo_block.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/protocol/TestProtocol/echo_block.pm,v
retrieving revision 1.1
diff -u -r1.1 echo_block.pm
--- t/protocol/TestProtocol/echo_block.pm 23 Apr 2004 01:37:54 -0000 1.1
+++ t/protocol/TestProtocol/echo_block.pm 3 May 2004 01:24:46 -0000
@@ -12,7 +12,7 @@
use APR::Socket ();
use Apache::Const -compile => 'OK';
-use APR::Const -compile => qw(SO_NONBLOCK);
+use APR::Const -compile => qw(SO_NONBLOCK TIMEUP EOF);
use constant BUFF_LEN => 1024;
@@ -32,16 +32,14 @@
or die "failed to set non-blocking mode";
}
- my ($buff, $rlen, $wlen);
- for (;;) {
- $rlen = BUFF_LEN;
- $socket->recv($buff, $rlen);
- last if $rlen <= 0;
+ while (1) {
+ my $buff = $socket->recv(BUFF_LEN);
+ my $wlen = length $buff;
- $wlen = $rlen;
- $socket->send($buff, $wlen);
+ last unless $wlen; # EOF
- last if $wlen != $rlen;
+ $socket->send($buff, $wlen);
+ last if $wlen != length $buff; # write failure
}
Apache::OK;
Index: t/protocol/TestProtocol/echo_timeout.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/protocol/TestProtocol/echo_timeout.pm,v
retrieving revision 1.1
diff -u -r1.1 echo_timeout.pm
--- t/protocol/TestProtocol/echo_timeout.pm 23 Apr 2004 01:37:54 -0000 1.1
+++ t/protocol/TestProtocol/echo_timeout.pm 3 May 2004 01:24:46 -0000
@@ -24,18 +24,24 @@
# read/write timeouts
$socket->timeout_set(20_000_000);
- my ($buff, $rlen, $wlen, $rc);
- for (;;) {
- $rlen = BUFF_LEN;
- $rc = $socket->recv($buff, $rlen);
- die "timeout on socket read" if $rc == APR::TIMEUP;
- last if $rlen <= 0;
+ while (1) {
+ my $buff = eval { $socket->recv(BUFF_LEN) };
+ if ($@) {
+ if ($@ == APR::TIMEUP) {
+ die "timed out, giving up";
+ }
+ else {
+ die $@;
+ }
+ }
+ my $wlen = length $buff;
- $wlen = $rlen;
- $rc = $socket->send($buff, $wlen);
+ last unless $wlen; # EOF
+
+ my $rc = $socket->send($buff, $wlen);
die "timeout on socket write" if $rc == APR::TIMEUP;
- last if $wlen != $rlen;
+ last if $wlen != length $buff; # write failure
}
Apache::OK;
Index: t/protocol/TestProtocol/eliza.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/protocol/TestProtocol/eliza.pm,v
retrieving revision 1.5
diff -u -r1.5 eliza.pm
--- t/protocol/TestProtocol/eliza.pm 14 Jun 2002 10:06:16 -0000 1.5
+++ t/protocol/TestProtocol/eliza.pm 3 May 2004 01:24:46 -0000
@@ -18,14 +18,13 @@
my Apache::Connection $c = shift;
my APR::Socket $socket = $c->client_socket;
- my $buff;
my $last = 0;
- for (;;) {
- my($rlen, $wlen);
- $rlen = BUFF_LEN;
- $socket->recv($buff, $rlen);
- last if $rlen <= 0;
-
+ while (1) {
+ my $buff = $socket->recv(BUFF_LEN);
+ my $wlen = length $buff;
+
+ last unless $wlen; # EOF
+
# \r is sent instead of \n if the client is talking over telnet
$buff =~ s/[\r\n]*$//;
$last++ if $buff eq "Good bye, Eliza";
Index: t/response/TestError/runtime.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestError/runtime.pm,v
retrieving revision 1.2
diff -u -r1.2 runtime.pm
--- t/response/TestError/runtime.pm 1 Apr 2003 04:39:30 -0000 1.2
+++ t/response/TestError/runtime.pm 3 May 2004 01:24:46 -0000
@@ -5,22 +5,123 @@
use Apache::RequestRec ();
use Apache::RequestIO ();
+use Apache::Connection ();
+use APR::Socket ();
use Apache::TestUtil;
use Apache::Const -compile => qw(OK);
+use APR::Const -compile => qw(TIMEUP);
+
+use constant SIZE => 2048;
sub handler {
my $r = shift;
+ my $socket = $r->connection->client_socket;
+ my $args = $r->args;
$r->content_type('text/plain');
- t_server_log_error_is_expected();
- no_such_func();
+ # set timeout to 1 usec (microsec!) which makes sure that any
+ # socket read call will fail
+ $socket->timeout_set(1);
- $r->print('ok');
+ no strict 'refs';
+ $args->($r, $socket);
return Apache::OK;
+}
+
+sub plain_mp_error {
+ my($r, $socket) = @_;
+ t_server_log_error_is_expected();
+ mp_error($socket);
+}
+
+sub plain_non_mp_error {
+ my($r, $socket) = @_;
+ t_server_log_error_is_expected();
+ non_mp_error($socket);
+}
+
+sub die_hook_confess_mp_error {
+ my($r, $socket) = @_;
+ local $SIG{__DIE__} = \&ModPerl::Error::confess;
+ t_server_log_error_is_expected();
+ mp_error($socket);
+}
+
+sub die_hook_confess_non_mp_error {
+ my($r, $socket) = @_;
+ local $SIG{__DIE__} = \&ModPerl::Error::confess;
+ t_server_log_error_is_expected();
+ non_mp_error($socket);
+}
+
+sub die_hook_custom_mp_error {
+ my($r, $socket) = @_;
+ local $SIG{__DIE__} = sub { die "custom die hook: $_[0]" };
+ t_server_log_error_is_expected();
+ mp_error($socket);
+}
+
+sub die_hook_custom_non_mp_error {
+ my($r, $socket) = @_;
+ local $SIG{__DIE__} = sub { die "custom die hook: $_[0]" };
+ t_server_log_error_is_expected();
+ non_mp_error($socket);
+}
+
+sub eval_block_mp_error {
+ my($r, $socket) = @_;
+ eval { mp_error($socket) };
+ if ($@ && ref($@) && $@ == APR::TIMEUP) {
+ $r->print("ok eval_block_mp_error");
+ }
+ else {
+ die "eval block has failed";
+ }
+}
+
+sub eval_string_mp_error {
+ my($r, $socket) = @_;
+ eval "\$socket->recv(SIZE)";
+ if ($@ && ref($@) && $@ == APR::TIMEUP) {
+ $r->print("ok eval_string_mp_error");
+ }
+ else {
+ die "eval string has failed";
+ }
+}
+
+sub eval_block_non_mp_error {
+ my($r, $socket) = @_;
+ eval { non_mp_error($socket) };
+ if ($@ && !ref($@)) {
+ $r->print("ok eval_block_non_mp_error");
+ }
+ else {
+ die "eval eval_non_mp_error has failed";
+ }
+}
+
+sub eval_block_non_error {
+ my($r, $socket) = @_;
+ eval { 1; };
+ if ($@) {
+ die "eval eval_block_non_mp_error has failed";
+ }
+ $r->print("ok eval_block_non_error");
+}
+
+sub non_mp_error {
+ no_such_func();
+}
+
+# fails because of the timeout set earlier in the handler
+sub mp_error {
+ my $socket = shift;
+ $socket->recv(SIZE);
}
1;
Index: t/response/TestModperl/exit.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestModperl/exit.pm,v
retrieving revision 1.2
diff -u -r1.2 exit.pm
--- t/response/TestModperl/exit.pm 11 Apr 2002 11:08:44 -0000 1.2
+++ t/response/TestModperl/exit.pm 3 May 2004 01:24:46 -0000
@@ -1,25 +1,38 @@
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;
-
- ModPerl::Util::exit();
+ $r->content_type('text/plain');
+ $r->print("ok");
+ my $args = $r->args;
+
+ if ($args eq 'eval') {
+ eval {
+ my $whatever = 1;
+ ModPerl::Util::exit();
+ };
+ ModPerl::Util::exit if $@ && ref $@ && $@ == ModPerl::EXIT;
+ }
+ elsif ($args eq 'noneval') {
+ ModPerl::Util::exit();
+ }
- #not reached
- ok 2;
+ # must not be reached
+ $r->print("must not be reached");
Apache::OK;
}
Index: xs/APR/Socket/APR__Socket.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/APR/Socket/APR__Socket.h,v
retrieving revision 1.7
diff -u -r1.7 APR__Socket.h
--- xs/APR/Socket/APR__Socket.h 23 Apr 2004 18:00:32 -0000 1.7
+++ xs/APR/Socket/APR__Socket.h 3 May 2004 01:24:46 -0000
@@ -14,21 +14,24 @@
*/
static MP_INLINE
-apr_status_t mpxs_apr_socket_recv(pTHX_ apr_socket_t *socket,
- SV *sv_buf, SV *sv_len)
+SV *mpxs_APR__Socket_recv(pTHX_ apr_socket_t *socket, int len)
{
- apr_status_t status;
- apr_size_t len = mp_xs_sv2_apr_size_t(sv_len);
+ SV *buf = NEWSV(0, len);
+ apr_status_t rc = apr_socket_recv(socket, SvPVX(buf), &len);
- mpxs_sv_grow(sv_buf, len);
- status = apr_socket_recv(socket, SvPVX(sv_buf), &len);
- mpxs_sv_cur_set(sv_buf, len);
-
- if (!SvREADONLY(sv_len)) {
- sv_setiv(sv_len, len);
+ if (len > 0) {
+ mpxs_sv_cur_set(buf, len);
+ SvTAINTED_on(buf);
+ }
+ else if (rc == APR_EOF) {
+ sv_setpvn(buf, "", 0);
}
-
- return status;
+ else if (rc != APR_SUCCESS) {
+ SvREFCNT_dec(buf);
+ modperl_croak(aTHX_ rc, "APR::Socket::recv");
+ }
+
+ return buf;
}
static MP_INLINE
Index: xs/maps/apr_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/apr_functions.map,v
retrieving revision 1.72
diff -u -r1.72 apr_functions.map
--- xs/maps/apr_functions.map 23 Apr 2004 18:00:32 -0000 1.72
+++ xs/maps/apr_functions.map 3 May 2004 01:24:47 -0000
@@ -44,7 +44,8 @@
!apr_socket_accept
apr_socket_listen
apr_socket_connect
- apr_socket_recv | mpxs_ | sock, SV *:buf, SV *:len
+-apr_socket_recv | mpxs_
+ mpxs_APR__Socket_recv
apr_socket_recvfrom
apr_socket_send | mpxs_ | sock, SV *:buf, SV *:len=Nullsv
apr_socket_sendto
Index: xs/tables/current/Apache/ConstantsTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/Apache/ConstantsTable.pm,v
retrieving revision 1.39
diff -u -r1.39 ConstantsTable.pm
--- xs/tables/current/Apache/ConstantsTable.pm 19 Apr 2004 23:18:01 -0000 1.39
+++ xs/tables/current/Apache/ConstantsTable.pm 3 May 2004 01:24:47 -0000
@@ -2,11 +2,16 @@
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# ! WARNING: generated by Apache::ParseSource/0.02
-# ! Mon Apr 19 16:15:31 2004
+# ! Fri Apr 30 15:07:36 2004
# ! do NOT edit, any changes will be lost !
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$Apache::ConstantsTable = {
+ 'ModPerl' => {
+ 'common' => [
+ 'MODPERL_CONST_EXIT'
+ ]
+ },
'Apache' => {
'types' => [
'DIR_MAGIC_TYPE'
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.153
diff -u -r1.153 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 23 Apr 2004 18:00:32 -0000 1.153
+++ xs/tables/current/ModPerl/FunctionTable.pm 3 May 2004 01:24:47 -0000
@@ -2,7 +2,7 @@
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# ! WARNING: generated by ModPerl::ParseSource/0.01
-# ! Thu Apr 22 21:47:52 2004
+# ! Fri Apr 30 16:12:55 2004
# ! do NOT edit, any changes will be lost !
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -1575,6 +1575,16 @@
]
},
{
+ 'return_type' => 'const char **',
+ 'name' => 'modperl_constants_group_lookup_modperl',
+ 'args' => [
+ {
+ 'type' => 'const char *',
+ 'name' => 'name'
+ }
+ ]
+ },
+ {
'return_type' => 'SV *',
'name' => 'modperl_constants_lookup_apache',
'args' => [
@@ -1603,6 +1613,34 @@
]
},
{
+ 'return_type' => 'SV *',
+ 'name' => 'modperl_constants_lookup_modperl',
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'name'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'void',
+ 'name' => 'modperl_croak',
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'apr_status_t',
+ 'name' => 'rc'
+ }
+ ]
+ },
+ {
'return_type' => 'unsigned long',
'name' => 'modperl_debug_level',
'args' => []
@@ -5446,6 +5484,24 @@
]
},
{
+ 'return_type' => 'SV *',
+ 'name' => 'mpxs_APR__Socket_recv',
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'apr_socket_t *',
+ 'name' => 'socket'
+ },
+ {
+ 'type' => 'int',
+ 'name' => 'len'
+ }
+ ]
+ },
+ {
'return_type' => 'void',
'name' => 'mpxs_APR__Socket_timeout_set',
'args' => [
@@ -7113,28 +7169,6 @@
{
'type' => 'apr_sockaddr_t *',
'name' => 'sockaddr'
- }
- ]
- },
- {
- 'return_type' => 'apr_status_t',
- 'name' => 'mpxs_apr_socket_recv',
- 'args' => [
- {
- 'type' => 'PerlInterpreter *',
- 'name' => 'my_perl'
- },
- {
- 'type' => 'apr_socket_t *',
- 'name' => 'socket'
- },
- {
- 'type' => 'SV *',
- 'name' => 'sv_buf'
- },
- {
- 'type' => 'SV *',
- 'name' => 'sv_len'
}
]
},
--- /dev/null 1969-12-31 16:00:00.000000000 -0800
+++ lib/ModPerl/Error.pm 2004-05-02 18:19:43.107498706 -0700
@@ -0,0 +1,49 @@
+package ModPerl::Error;
+
+use strict;
+use warnings FATAL => 'all';
+
+require Carp;
+require Carp::Heavy;
+
+use APR::Util ();
+
+use overload
+ nomethod => \&fatal,
+ 'bool' => \&str,
+ '==' => \&num,
+ '0+' => \&num,
+ '""' => \&str;
+
+sub fatal { die __PACKAGE__ . ": Can't handle '$_[3]'" }
+
+sub new {
+ my ($class, $num) = @_;
+ bless \$num, $class;
+}
+
+sub str {
+ "$_[0]->{func}: " . APR::strerror($_[0]->{num}) .
+ " at $_[0]->{file} line $_[0]->{line}";
+}
+
+sub num { $_[0]->{num} }
+
+# XXX: Carp::confess sees no calls stack when Perl_croak is called
+# with Nullch (which is the way execption objects are returned), so we
+# fixup it here (doesn't quite work for croak caller).
+#
+# skip this wrapper from the long callers trace
+$Carp::CarpInternal{+__PACKAGE__}++;
+sub confess {
+ if (ref $_[0] eq __PACKAGE__) {
+ Carp::confess("$_[0]->{func}: " . APR::strerror($_[0]->{num}));
+ }
+ else {
+ &Carp::confess;
+ }
+}
+
+
+1;
+
--- /dev/null 1969-12-31 16:00:00.000000000 -0800
+++ t/modperl/exit.t 2004-05-02 14:19:20.000000000 -0700
@@ -0,0 +1,17 @@
+use Apache::TestRequest 'GET_BODY_ASSERT';
+
+use Apache::Test;
+use Apache::TestUtil;
+
+my $location = "/TestModperl__exit";
+
+plan tests => 2;
+
+ok t_cmp('ok',
+ GET_BODY_ASSERT("$location?noneval"),
+ "exit in non eval context");
+
+ok t_cmp('ok',
+ GET_BODY_ASSERT("$location?eval"),
+ "exit in eval context");
+
--
__________________________________________________________________
Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org http://ticketmaster.com
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org
Re: [mp2 patch] exception objects
Posted by Stas Bekman <st...@stason.org>.
> Question:
> - how should we name the defines for exception codes? I did
> MODPERL_CONST_EXIT for the EXIT exception. Or should it be
> MODPERL_ERROR_EXIT or else?
I think it's confusing on the C side to have CONST (since it has nothing to do
with const in C). I think I'll call it either:
MODPERL_RC_EXIT
or
MODPERL_CODE_EXIT
Most likely the former, so all ReturnCodes added by ModPerl will live in
MODPERL_RC_, which makes the C code easier to grok:
if (sv_derived_from(sv, "ModPerl::Error") &&
SvIVx(sv) == MODPERL_RC_EXIT) {
/* ModPerl::Util::exit was called */
return OK;
--
__________________________________________________________________
Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org http://ticketmaster.com
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org