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('[EMAIL PROTECTED]', $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 *',