You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by ge...@apache.org on 2004/01/14 22:27:41 UTC
cvs commit: modperl-2.0/xs/tables/current/ModPerl FunctionTable.pm
geoff 2004/01/14 13:27:41
Modified: . Changes
lib/Apache compat.pm
src/modules/perl modperl_util.c modperl_util.h
t/response/TestAPI server_util.pm
t/response/TestAPR finfo.pm
t/response/TestCompat apache.pm
todo release
xs/Apache/Connection Apache__Connection.h
xs/Apache/RequestRec Apache__RequestRec.h
xs/Apache/ServerUtil Apache__ServerUtil.h
xs/maps apache_functions.map modperl_functions.map
xs/tables/current/Apache FunctionTable.pm
xs/tables/current/ModPerl FunctionTable.pm
Log:
server_root_relative() now requires either a valid pool or an $r, $s, or $c
object as a first argument. also, the returned result is a copy, protecting
against cases where the pool would go out of scope before the result.
Revision Changes Path
1.301 +5 -0 modperl-2.0/Changes
Index: Changes
===================================================================
RCS file: /home/cvs/modperl-2.0/Changes,v
retrieving revision 1.300
retrieving revision 1.301
diff -u -r1.300 -r1.301
--- Changes 11 Jan 2004 20:22:56 -0000 1.300
+++ Changes 14 Jan 2004 21:27:40 -0000 1.301
@@ -12,6 +12,11 @@
=item 1.99_13-dev
+server_root_relative() now requires either a valid pool or an $r, $s, or $c
+object as a first argument. also, the returned result is a copy, protecting
+against cases where the pool would go out of scope before the result.
+[Geoffrey Young]
+
Check the success of sysopen in tmpfile() in compat [Geoffrey Young]
make sure DynaLoader is loaded before XSLoader, not only with perl
1.96 +15 -4 modperl-2.0/lib/Apache/compat.pm
Index: compat.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/Apache/compat.pm,v
retrieving revision 1.95
retrieving revision 1.96
diff -u -r1.95 -r1.96
--- compat.pm 11 Jan 2004 20:22:56 -0000 1.95
+++ compat.pm 14 Jan 2004 21:27:40 -0000 1.96
@@ -139,6 +139,20 @@
}
EOI
+ 'Apache::server_root_relative' => <<'EOI',
+{
+ require Apache::Server;
+ require Apache::ServerUtil;
+
+ my $orig_sub = *Apache::server_root_relative{CODE};
+ *Apache::server_root_relative = sub {
+ my $class = shift;
+ return Apache->server->server_root_relative(@_);
+ };
+ $orig_sub;
+}
+EOI
+
);
my %overridden_mp2_api = ();
@@ -210,7 +224,7 @@
package Apache::Server;
# XXX: is that good enough? see modperl/src/modules/perl/mod_perl.c:367
-our $CWD = Apache->server_root_relative();
+our $CWD = Apache::server_root;
our $AddPerlVersion = 1;
@@ -334,9 +348,6 @@
$r->content_type($type);
}
-
-#to support $r->server_root_relative
-*server_root_relative = \&Apache::server_root_relative;
#we support Apache->request; this is needed to support $r->request
#XXX: seems sorta backwards
1.60 +52 -28 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.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- modperl_util.c 19 Dec 2003 01:17:32 -0000 1.59
+++ modperl_util.c 14 Jan 2004 21:27:40 -0000 1.60
@@ -172,39 +172,30 @@
return rv;
}
-apr_pool_t *modperl_sv2pool(pTHX_ SV *obj)
+static apr_pool_t *modperl_sv2pool(pTHX_ SV *obj, CV *method)
{
apr_pool_t *p = NULL;
char *classname = NULL;
IV ptr = 0;
- /*
- * if inside request and 'PerlOptions +GlobalRequest' for this interp,
- * get the pool from the current request
- * else return the global pool
- */
- if (!SvOK(obj)) {
- request_rec *r = NULL;
- (void)modperl_tls_get_request_rec(&r);
-
- if (r) {
- return r->pool;
- }
-
- return modperl_global_get_pconf();
- }
-
if ((SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVMG))) {
+ /* standard classes */
+ classname = SvCLASS(obj);
ptr = SvObjIV(obj);
+ }
+ else if ((SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVHV))) {
+ /* Apache::RequestRec subclass */
classname = SvCLASS(obj);
+ ptr = SvIV(modperl_hv_request_find(aTHX_ obj, classname, method));
+
+ /* if modperl_hv_request_find succeeeds then the class is an
+ * Apache::RequestRec subclass (the only subclass we support).
+ * so, fake things a bit so we can dig out the proper pool below
+ */
+ classname = "Apache::RequestRec";
}
else {
- STRLEN len;
- classname = SvPV(obj, len);
- }
-
- if (*classname != 'A') {
- /* XXX: could be a subclass */
+ MP_TRACE_m(MP_FUNC, "SV not a recognized object");
return NULL;
}
@@ -213,10 +204,11 @@
switch (*classname) {
case 'P':
if (strEQ(classname, "Pool")) {
- p = (apr_pool_t *)ptr;
+ p = (apr_pool_t *)SvObjIV(obj);
}
break;
default:
+ MP_TRACE_m(MP_FUNC, "class %s not recognized", classname);
break;
};
}
@@ -225,25 +217,33 @@
switch (*classname) {
case 'C':
if (strEQ(classname, "Connection")) {
- p = ptr ? ((conn_rec *)ptr)->pool : NULL;
+ p = ((conn_rec *)ptr)->pool;
}
break;
case 'R':
if (strEQ(classname, "RequestRec")) {
- p = ptr ? ((request_rec *)ptr)->pool : NULL;
+ p = ((request_rec *)ptr)->pool;
}
break;
case 'S':
if (strEQ(classname, "Server")) {
- p = ptr ? ((server_rec *)ptr)->process->pconf : NULL;
+ p = ((server_rec *)ptr)->process->pconf;
}
break;
default:
+ MP_TRACE_m(MP_FUNC, "class %s not recognised", classname);
break;
};
}
+ else {
+ MP_TRACE_m(MP_FUNC, "class %s not recognised", classname);
+ }
+
+ if (p == NULL) {
+ MP_TRACE_m(MP_FUNC, "unable to derive pool from object");
+ }
- return p ? p : modperl_global_get_pconf();
+ return p;
}
char *modperl_apr_strerror(apr_status_t rv)
@@ -818,4 +818,28 @@
}
return package;
+}
+
+/* this is used across server_root_relative() in the
+ * Apache, Apache::Server, Apache::RequestRec, and
+ * Apache::Connection classes
+ */
+SV *modperl_server_root_relative(pTHX_ SV *sv, const char *fname)
+{
+ apr_pool_t *p;
+
+ if (!sv_isobject(sv)) {
+ Perl_croak(aTHX_ "usage: Apache::server_root_relative(obj, name)");
+ }
+
+ p = modperl_sv2pool(aTHX_ sv, get_cv("Apache::server_root_relative", 0));
+
+ if (p == NULL) {
+ MP_TRACE_a(MP_FUNC,
+ "unable to isolate pool for ap_server_root_relative()");
+ return &PL_sv_undef;
+ }
+
+ /* copy the SV in case the pool goes out of scope before the perl scalar */
+ return newSVpv(ap_server_root_relative(p, fname), 0);
}
1.51 +3 -2 modperl-2.0/src/modules/perl/modperl_util.h
Index: modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- modperl_util.h 9 Jan 2004 00:12:07 -0000 1.50
+++ modperl_util.h 14 Jan 2004 21:27:40 -0000 1.51
@@ -87,8 +87,6 @@
MP_INLINE SV *modperl_perl_sv_setref_uv(pTHX_ SV *rv,
const char *classname, UV uv);
-apr_pool_t *modperl_sv2pool(pTHX_ SV *obj);
-
char *modperl_apr_strerror(apr_status_t rv);
int modperl_errsv(pTHX_ int status, request_rec *r, server_rec *s);
@@ -161,4 +159,7 @@
#endif
char *modperl_file2package(apr_pool_t *p, const char *file);
+
+SV *modperl_server_root_relative(pTHX_ SV *sv, const char *fname);
+
#endif /* MODPERL_UTIL_H */
1.6 +87 -19 modperl-2.0/t/response/TestAPI/server_util.pm
Index: server_util.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestAPI/server_util.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- server_util.pm 11 Apr 2002 11:08:43 -0000 1.5
+++ server_util.pm 14 Jan 2004 21:27:41 -0000 1.6
@@ -5,43 +5,111 @@
use Apache::Test;
use Apache::TestUtil;
+use File::Spec::Functions qw(canonpath catfile);
use Apache::RequestRec ();
use Apache::ServerUtil ();
+use Apache::Process ();
+
+use APR::Pool ();
use Apache::Const -compile => 'OK';
-sub handler {
- my $r = shift;
+my $serverroot = Apache::Test::config()->{vars}->{serverroot};
- my $s = $r->server;
+our @ISA = qw(Apache::RequestRec);
- plan $r, tests => 9;
+sub new {
+ my $class = shift;
+ my $r = shift;
+ bless { r => $r }, $class;
+}
- for my $p ($r->pool, $r->connection->pool,
- $r, $r->connection, $r->server)
- {
- my $dir = Apache::server_root_relative($p, 'conf');
+sub handler {
- ok -d $dir;
- }
+ my $r = shift;
- my $dir = Apache::server_root; #constant
+ my %pools = (
+ '$r->pool' => $r->pool,
+ '$r->connection->pool' => $r->connection->pool,
+ '$r->server->process->pool' => $r->server->process->pool,
+ '$r->server->process->pconf' => $r->server->process->pconf,
+ 'Apache->server->process->pconf' => Apache->server->process->pconf,
+ 'APR::Pool->new' => APR::Pool->new,
+ );
+
+ my %objects = (
+ '$r' => $r,
+ '$r->connection' => $r->connection,
+ '$r->server' => $r->server,
+ '__PACKAGE__->new($r)' => __PACKAGE__->new($r),
+ );
+
+ plan $r, tests => (scalar keys %pools) +
+ (scalar keys %objects) + 8;
+
+ # syntax - an object or pool is required
+ t_debug("Apache::server_root_relative() died");
+ eval { my $dir = Apache::server_root_relative() };
+ t_debug("\$\@: $@");
+ ok $@;
+
+ t_debug("Apache->server_root_relative() died");
+ eval { my $dir = Apache->server_root_relative() };
+ ok $@;
+
+ # syntax - first argument must be an object, not a class
+ t_debug("Apache->server_root_relative('conf') died");
+ eval { my $dir = Apache->server_root_relative('conf') };
+ ok $@;
+
+ foreach my $p (keys %pools) {
+
+ ok t_cmp(catfile($serverroot, 'conf'),
+ Apache::server_root_relative($pools{$p}, 'conf'),
+ "Apache::server_root_relative($p, 'conf')");
+ }
- ok -d $dir;
+ # dig out the pool from valid objects
+ foreach my $obj (keys %objects) {
- $dir = join '/', Apache::server_root, 'logs';
+ ok t_cmp(catfile($serverroot, 'conf'),
+ $objects{$obj}->server_root_relative('conf'),
+ "$obj->server_root_relative('conf')");
+ }
- ok $dir eq Apache::server_root_relative($r->pool, 'logs');
+ # syntax - unrecognized objects don't segfault
+ {
+ my $obj = bless {}, 'Apache::Foo';
+ eval { Apache::server_root_relative($obj, 'conf') };
- $dir = Apache->server_root_relative('logs'); #1.x ish
+ ok t_cmp(qr/server_root_relative.*no .* key/,
+ $@,
+ "Apache::server_root_relative(\$obj, 'conf')");
+ }
- ok -d $dir;
+ # no file argument gives ServerRoot
+ ok t_cmp(canonpath($serverroot),
+ canonpath($r->server_root_relative),
+ '$r->server_root_relative()');
+
+ ok t_cmp(canonpath($serverroot),
+ canonpath(Apache::server_root_relative($r->pool)),
+ 'Apache::server_root_relative($r->pool)');
+
+ # Apache::server_root is also the ServerRoot constant
+ ok t_cmp(canonpath(Apache::server_root),
+ canonpath($r->server_root_relative),
+ 'Apache::server_root');
- #$r->server_root_relative works with use Apache::compat
- $dir = Apache->server_root_relative(); #1.x ish
+ {
+ # absolute paths should resolve to themselves
+ my $dir = $r->server_root_relative('logs');
- ok -d $dir;
+ ok t_cmp($r->server_root_relative($dir),
+ $dir,
+ "\$r->server_root_relative($dir)");
+ }
Apache::OK;
}
1.8 +1 -1 modperl-2.0/t/response/TestAPR/finfo.pm
Index: finfo.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestAPR/finfo.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- finfo.pm 16 Dec 2003 18:13:04 -0000 1.7
+++ finfo.pm 14 Jan 2004 21:27:41 -0000 1.8
@@ -40,7 +40,7 @@
ok $isa;
}
- my $file = Apache->server_root_relative(catfile qw(htdocs index.html));
+ my $file = $r->server_root_relative(catfile qw(htdocs index.html));
# stat tests
{
1.8 +29 -1 modperl-2.0/t/response/TestCompat/apache.pm
Index: apache.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestCompat/apache.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- apache.pm 21 Oct 2003 22:20:18 -0000 1.7
+++ apache.pm 14 Jan 2004 21:27:41 -0000 1.8
@@ -9,6 +9,7 @@
use Apache::TestUtil;
use Apache::Test;
+use File::Spec::Functions qw(catfile canonpath);
use Apache::compat ();
use Apache::Constants qw(DIR_MAGIC_TYPE :common :response);
@@ -16,7 +17,7 @@
sub handler {
my $r = shift;
- plan $r, tests => 11;
+ plan $r, tests => 16;
$r->send_http_header('text/plain');
@@ -62,6 +63,33 @@
ok t_cmp('foo@bar.com', $r->server->server_admin,
'Apache->httpd_conf');
$r->server->server_admin($admin);
+
+ ok t_cmp(canonpath($Apache::Server::CWD),
+ canonpath(Apache::Test::config()->{vars}->{serverroot}),
+ '$Apache::Server::CWD');
+
+ ok t_cmp(canonpath($Apache::Server::CWD),
+ canonpath($r->server_root_relative),
+ '$r->server_root_relative()');
+
+ ok t_cmp(catfile($Apache::Server::CWD, 'conf'),
+ $r->server_root_relative('conf'),
+ "\$r->server_root_relative('conf')");
+
+ # Apache->server_root_relative
+ {
+ Apache::compat::override_mp2_api('Apache::server_root_relative');
+
+ ok t_cmp(catfile($Apache::Server::CWD, 'conf'),
+ Apache->server_root_relative('conf'),
+ "Apache->server_root_relative('conf')");
+
+ ok t_cmp(canonpath($Apache::Server::CWD),
+ canonpath(Apache->server_root_relative),
+ 'Apache->server_root_relative()');
+
+ Apache::compat::restore_mp2_api('Apache::server_root_relative');
+ }
OK;
}
1.8 +0 -8 modperl-2.0/todo/release
Index: release
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/release,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- release 14 Jan 2004 20:36:01 -0000 1.7
+++ release 14 Jan 2004 21:27:41 -0000 1.8
@@ -143,14 +143,6 @@
http://marc.theaimsgroup.com/?l=apache-modperl-dev&m=100622977803237&w=2
http://marc.theaimsgroup.com/?t=97984528900002&r=1&w=2
-* Apache->server_root_relative:
- needs to default to current pool (pconf at startup, r->pool at
- request time) - solution: require the pool object to be passed. if a
- user doesn't have one, make them create one, e.g.:
- Apache::server_root_relative(APR::Pool->new, ....). Must make sure
- that the returned SV has a copy of that string and doesn't rely on
- anything that it's in pool, which will be now destroyed.
-
* $r->cleanup_for_exec needs to be added to Apache::compat as a noop.
Owner: stas
1.8 +3 -0 modperl-2.0/xs/Apache/Connection/Apache__Connection.h
Index: Apache__Connection.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/Apache/Connection/Apache__Connection.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- Apache__Connection.h 24 Aug 2002 17:16:45 -0000 1.7
+++ Apache__Connection.h 14 Jan 2004 21:27:41 -0000 1.8
@@ -24,3 +24,6 @@
{
return ap_get_remote_host(c, (void *)dir_config, type, NULL);
}
+
+#define mpxs_Apache__Connection_server_root_relative(sv, fname) \
+ modperl_server_root_relative(aTHX_ sv, fname)
1.8 +4 -0 modperl-2.0/xs/Apache/RequestRec/Apache__RequestRec.h
Index: Apache__RequestRec.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/Apache/RequestRec/Apache__RequestRec.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- Apache__RequestRec.h 18 Dec 2003 18:53:50 -0000 1.7
+++ Apache__RequestRec.h 14 Jan 2004 21:27:41 -0000 1.8
@@ -59,3 +59,7 @@
{
return &r->finfo;
}
+
+#define mpxs_Apache__RequestRec_server_root_relative(sv, fname) \
+ modperl_server_root_relative(aTHX_ sv, fname)
+
1.10 +4 -7 modperl-2.0/xs/Apache/ServerUtil/Apache__ServerUtil.h
Index: Apache__ServerUtil.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/Apache/ServerUtil/Apache__ServerUtil.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- Apache__ServerUtil.h 10 Jan 2004 02:52:20 -0000 1.9
+++ Apache__ServerUtil.h 14 Jan 2004 21:27:41 -0000 1.10
@@ -42,14 +42,11 @@
#define mpxs_Apache_server(classname) \
modperl_global_get_server_rec()
-static MP_INLINE char *mpxs_ap_server_root_relative(pTHX_
- SV *sv,
- const char *fname)
-{
- apr_pool_t *p = modperl_sv2pool(aTHX_ sv);
+#define mpxs_Apache__Server_server_root_relative(sv, fname) \
+ modperl_server_root_relative(aTHX_ sv, fname);
- return ap_server_root_relative(p, fname);
-}
+#define mpxs_Apache_server_root_relative(sv, fname) \
+ modperl_server_root_relative(aTHX_ sv, fname)
static MP_INLINE
int mpxs_Apache__Server_is_perl_option_enabled(pTHX_ server_rec *s,
1.67 +1 -1 modperl-2.0/xs/maps/apache_functions.map
Index: apache_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/apache_functions.map,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- apache_functions.map 1 Dec 2003 17:14:16 -0000 1.66
+++ apache_functions.map 14 Jan 2004 21:27:41 -0000 1.67
@@ -166,7 +166,7 @@
ap_get_server_built
ap_get_server_version
ap_psignature | | r,prefix
- ap_server_root_relative | mpxs_ | SV *:p, fname=""
+~ap_server_root_relative
MODULE=Apache::Connection PACKAGE=guess
#XXX: thought this might be useful for protocol modules
1.65 +4 -0 modperl-2.0/xs/maps/modperl_functions.map
Index: modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- modperl_functions.map 10 Jan 2004 02:52:20 -0000 1.64
+++ modperl_functions.map 14 Jan 2004 21:27:41 -0000 1.65
@@ -16,6 +16,7 @@
mpxs_Apache__RequestRec_proxyreq | | r, val=Nullsv
mpxs_Apache__RequestRec_subprocess_env | | r, key=NULL, val=Nullsv
mpxs_Apache__RequestRec_finfo
+ SV *:DEFINE_server_root_relative | | SV *:p, const char *:fname=""
MODULE=Apache::RequestUtil PACKAGE=guess
mpxs_Apache__RequestRec_push_handlers
@@ -73,12 +74,15 @@
PACKAGE=Apache::Server
SV *:DEFINE_dir_config | | server_rec *:s, char *:key=NULL, SV *:sv_val=Nullsv
+ SV *:DEFINE_server_root_relative | | SV *:p, const char *:fname=""
PACKAGE=Apache
server_rec *:DEFINE_server | | SV *:classname=Nullsv
+ SV *:DEFINE_server_root_relative | | SV *:p, const char *:fname=""
MODULE=Apache::Connection
mpxs_Apache__Connection_client_socket | | c, s=NULL
+ SV *:DEFINE_server_root_relative | | SV *:p, const char *:fname=""
MODULE=Apache::Filter
modperl_filter_attributes | MPXS_ | ... | MODIFY_CODE_ATTRIBUTES
1.52 +1 -1 modperl-2.0/xs/tables/current/Apache/FunctionTable.pm
Index: FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/Apache/FunctionTable.pm,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- FunctionTable.pm 8 Dec 2003 19:31:53 -0000 1.51
+++ FunctionTable.pm 14 Jan 2004 21:27:41 -0000 1.52
@@ -4724,7 +4724,7 @@
]
},
{
- 'return_type' => 'char *',
+ 'return_type' => 'SV *',
'name' => 'ap_server_root_relative',
'args' => [
{
1.136 +2 -6 modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm
Index: FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.135
retrieving revision 1.136
diff -u -r1.135 -r1.136
--- FunctionTable.pm 10 Jan 2004 02:52:20 -0000 1.135
+++ FunctionTable.pm 14 Jan 2004 21:27:41 -0000 1.136
@@ -6338,12 +6338,8 @@
]
},
{
- 'return_type' => 'char *',
- 'name' => 'mpxs_ap_server_root_relative',
- 'attr' => [
- 'static',
- '__inline__'
- ],
+ 'return_type' => 'SV *',
+ 'name' => 'modperl_server_root_relative',
'args' => [
{
'type' => 'PerlInterpreter *',