> it won't apply over the is_perl_option_enabled stuff you just posted, so
> I'll wait until monday to rework it into core and commit, even if there are
> no technical changes to be made.
wow, that was a fast commit :)
anyway, here's a patch against current cvs for you to review when you have
time - I'm off for the weekend, so I'll still only get to it monday.
--Geoff
Index: Changes
===================================================================
RCS file: /home/cvspublic/modperl-2.0/Changes,v
retrieving revision 1.298
diff -u -r1.298 Changes
--- Changes 10 Jan 2004 02:52:20 -0000 1.298
+++ Changes 10 Jan 2004 03:04:24 -0000
@@ -11,6 +11,8 @@
=over 3
=item 1.99_13-dev
+server_root_relative() will now derive the pool if called from
+$r, $s, or $c objects. [Geoffrey Young]
added ($r|$s)->is_perl_option_enabled($option_name), to test for
PerlOptions + tests [Stas]
Index: src/modules/perl/modperl_util.c
===================================================================
RCS file: /home/cvspublic/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.59
diff -u -r1.59 modperl_util.c
--- src/modules/perl/modperl_util.c 19 Dec 2003 01:17:32 -0000 1.59
+++ src/modules/perl/modperl_util.c 10 Jan 2004 03:04:24 -0000
@@ -194,6 +194,12 @@
return modperl_global_get_pconf();
}
+ /* $r->server_root_relative($name), or
+ * Apache->server_root_relative($p, $name)
+ *
+ * for $(r|c|s) dig out the pool from the record
+ * otherwise use the pool provided
+ */
if ((SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVMG))) {
ptr = SvObjIV(obj);
classname = SvCLASS(obj);
@@ -204,8 +210,13 @@
}
if (*classname != 'A') {
- /* XXX: could be a subclass */
- return NULL;
+ /* XXX: could be a subclass, but more likely
+ * Apache::server_root_relative($name);
+ * note no -> so $name is the class
+ * avoid core dumps by returning the global pool,
+ * even though it then gives just the ServerRoot back
+ */
+ return modperl_global_get_pconf();
}
if (strnEQ(classname, "APR::", 5)) {
Index: t/response/TestAPI/server_util.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/t/response/TestAPI/server_util.pm,v
retrieving revision 1.5
diff -u -r1.5 server_util.pm
--- t/response/TestAPI/server_util.pm 11 Apr 2002 11:08:43 -0000 1.5
+++ t/response/TestAPI/server_util.pm 10 Jan 2004 03:04:24 -0000
@@ -5,43 +5,96 @@
use Apache::Test;
use Apache::TestUtil;
+use File::Spec::Functions qw(canonpath catfile);
use Apache::RequestRec ();
use Apache::ServerUtil ();
+use Apache::Process ();
-use Apache::Const -compile => 'OK';
+use APR::Pool ();
-sub handler {
- my $r = shift;
+use Apache::Const -compile => 'OK';
- my $s = $r->server;
+my $serverroot = Apache::Test::config()->{vars}->{serverroot};
- plan $r, tests => 9;
+sub handler {
- for my $p ($r->pool, $r->connection->pool,
- $r, $r->connection, $r->server)
- {
- my $dir = Apache::server_root_relative($p, 'conf');
+ my $r = shift;
- ok -d $dir;
+ 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,
+ 'APR::Pool->new' => APR::Pool->new,
+ );
+
+ my %objects = ( '$r' => $r,
+ '$r->connection' => $r->connection,
+ '$r->server' => $r->server,
+ );
+
+ plan $r, tests => (scalar keys %pools) +
+ (scalar keys %objects) + 7;
+
+ # pass a pool directly to the function call
+ foreach my $p (keys %pools) {
+
+ ok t_cmp(catfile($serverroot, 'conf'),
+ Apache::server_root_relative($pools{$p}, 'conf'),
+ "Apache::server_root_relative($p, 'conf')");
}
- my $dir = Apache::server_root; #constant
-
- ok -d $dir;
-
- $dir = join '/', Apache::server_root, 'logs';
+ # dig out the pool from the core objects
+ foreach my $obj (keys %objects) {
- ok $dir eq Apache::server_root_relative($r->pool, 'logs');
+ t_debug("$obj->server_root_relative('conf')");
- $dir = Apache->server_root_relative('logs'); #1.x ish
+ ok t_cmp(catfile($serverroot, 'conf'),
+ $objects{$obj}->server_root_relative('conf'),
+ "$obj->server_root_relative('conf')");
+ }
- ok -d $dir;
+ # no real class - uses global pool
+ ok t_cmp(catfile($serverroot, 'conf'),
+ Apache->server_root_relative('conf'),
+ "Apache->server_root_relative('conf')");
+
+ # no file argument gives ServerRoot
+ ok t_cmp(canonpath($serverroot),
+ canonpath(Apache->server_root_relative),
+ 'Apache->server_root_relative()');
+
+ ok t_cmp(canonpath($serverroot),
+ canonpath($r->server_root_relative),
+ '$r->server_root_relative()');
+
+ # Apache::server_root is also the ServerRoot constant
+ ok t_cmp(canonpath(Apache::server_root),
+ canonpath($r->server_root_relative),
+ 'Apache::server_root');
+
+ # a class or pool is required
+ t_debug("Apache::server_root_relative() died");
+ eval { my $dir = Apache::server_root_relative() };
+ ok $@;
+
+ # XXX 'conf' is not an object or class, so we use
+ # the global pool. in the process 'conf' is soaked up
+ # and we act as though we were called with no args
+ my $dir = Apache::server_root_relative('conf');
+
+ ok t_cmp(Apache->server_root_relative,
+ Apache::server_root_relative('conf'),
+ "Apache::server_root_relative('conf')");
- #$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;
}
Index: todo/release
===================================================================
RCS file: /home/cvspublic/modperl-2.0/todo/release,v
retrieving revision 1.6
diff -u -r1.6 release
--- todo/release 19 Dec 2003 01:17:32 -0000 1.6
+++ todo/release 10 Jan 2004 03:04:24 -0000
@@ -139,14 +139,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
Index: xs/Apache/ServerUtil/Apache__ServerUtil.h
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/Apache/ServerUtil/Apache__ServerUtil.h,v
retrieving revision 1.9
diff -u -r1.9 Apache__ServerUtil.h
--- xs/Apache/ServerUtil/Apache__ServerUtil.h 10 Jan 2004 02:52:20 -0000 1.9
+++ xs/Apache/ServerUtil/Apache__ServerUtil.h 10 Jan 2004 03:04:24 -0000
@@ -42,13 +42,37 @@
#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)
+static MP_INLINE SV *mpxs_ap_server_root_relative(pTHX_
+ SV *sv,
+ const char *fname)
{
apr_pool_t *p = modperl_sv2pool(aTHX_ sv);
- return ap_server_root_relative(p, fname);
+ return newSVpv(ap_server_root_relative(p, fname), 0);
+}
+
+static MP_INLINE
+SV *mpxs_Apache__RequestRec_server_root_relative(pTHX_
+ SV *sv,
+ const char *fname)
+{
+ return mpxs_ap_server_root_relative(aTHX_ sv, fname);
+}
+
+static MP_INLINE
+SV *mpxs_Apache__Server_server_root_relative(pTHX_
+ SV *sv,
+ const char *fname)
+{
+ return mpxs_ap_server_root_relative(aTHX_ sv, fname);
+}
+
+static MP_INLINE
+SV *mpxs_Apache__Connection_server_root_relative(pTHX_
+ SV *sv,
+ const char *fname)
+{
+ return mpxs_ap_server_root_relative(aTHX_ sv, fname);
}
static MP_INLINE
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.64
diff -u -r1.64 modperl_functions.map
--- xs/maps/modperl_functions.map 10 Jan 2004 02:52:20 -0000 1.64
+++ xs/maps/modperl_functions.map 10 Jan 2004 03:04:24 -0000
@@ -71,8 +71,15 @@
mpxs_Apache__Server_is_perl_option_enabled
modperl_config_insert_server | | | add_config
+PACKAGE=Apache::RequestRec
+ mpxs_Apache__RequestRec_server_root_relative | | SV *:p, fname=""
+
PACKAGE=Apache::Server
SV *:DEFINE_dir_config | | server_rec *:s, char *:key=NULL, SV *:sv_val=Nullsv
+ mpxs_Apache__Server_server_root_relative | | SV *:p, fname=""
+
+PACKAGE=Apache::Connection
+ mpxs_Apache__Connection_server_root_relative | | SV *:p, fname=""
PACKAGE=Apache
server_rec *:DEFINE_server | | SV *:classname=Nullsv
Index: xs/tables/current/Apache/FunctionTable.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/tables/current/Apache/FunctionTable.pm,v
retrieving revision 1.51
diff -u -r1.51 FunctionTable.pm
--- xs/tables/current/Apache/FunctionTable.pm 8 Dec 2003 19:31:53 -0000 1.51
+++ xs/tables/current/Apache/FunctionTable.pm 10 Jan 2004 03:04:25 -0000
@@ -4724,7 +4724,7 @@
]
},
{
- 'return_type' => 'char *',
+ 'return_type' => 'SV *',
'name' => 'ap_server_root_relative',
'args' => [
{
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.135
diff -u -r1.135 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 10 Jan 2004 02:52:20 -0000 1.135
+++ xs/tables/current/ModPerl/FunctionTable.pm 10 Jan 2004 03:04:25 -0000
@@ -6338,7 +6338,7 @@
]
},
{
- 'return_type' => 'char *',
+ 'return_type' => 'SV *',
'name' => 'mpxs_ap_server_root_relative',
'attr' => [
'static',
@@ -6352,6 +6352,72 @@
{
'type' => 'SV *',
'name' => 'sv'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'fname'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'SV *',
+ 'name' => 'mpxs_Apache__RequestRec_server_root_relative',
+ 'attr' => [
+ 'static',
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'p'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'fname'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'SV *',
+ 'name' => 'mpxs_Apache__Server_server_root_relative',
+ 'attr' => [
+ 'static',
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'p'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'fname'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'SV *',
+ 'name' => 'mpxs_Apache__Connection_server_root_relative',
+ 'attr' => [
+ 'static',
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'p'
},
{
'type' => 'const char *',
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
