dougm 01/04/28 15:35:23
Modified: lib/ModPerl TypeMap.pm WrapXS.pm
src/modules/perl modperl_util.c modperl_util.h
xs modperl_xs_util.h
xs/maps apache_functions.map
Added: t/response/TestAPI uri.pm
xs/Apache/URI Apache__URI.h
Log:
add Apache::URI interface and tests
Revision Changes Path
1.6 +6 -4 modperl-2.0/lib/ModPerl/TypeMap.pm
Index: TypeMap.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/TypeMap.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- TypeMap.pm 2001/03/16 00:26:29 1.5
+++ TypeMap.pm 2001/04/28 22:35:18 1.6
@@ -332,10 +332,12 @@
}
#XXX: generate this
-my %class_pools = (
- 'Apache::RequestRec' => '.pool',
- 'Apache::Connection' => '.pool',
-);
+my %class_pools = map {
+ (my $f = "mpxs_${_}_pool") =~ s/:/_/g;
+ $_, $f;
+} qw{
+ Apache::RequestRec Apache::Connection Apache::URI
+};
sub class_pool : lvalue {
my($self, $class) = @_;
1.9 +1 -1 modperl-2.0/lib/ModPerl/WrapXS.pm
Index: WrapXS.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/WrapXS.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- WrapXS.pm 2001/04/20 18:03:45 1.8
+++ WrapXS.pm 2001/04/28 22:35:19 1.9
@@ -150,7 +150,7 @@
if ($e->{class} eq 'PV') {
if (my $pool = $e->{pool}) {
- $pool =~ s/^\./obj->/;
+ $pool .= '(obj)';
$val = "((ST(1) == &PL_sv_undef) ? NULL :
(SvPOK(ST(1)) ?
apr_pstrndup($pool, SvPVX(ST(1)), SvCUR(ST(1))) :
1.10 +40 -0 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.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- modperl_util.c 2001/04/25 05:27:17 1.9
+++ modperl_util.c 2001/04/28 22:35:20 1.10
@@ -66,6 +66,46 @@
return sv;
}
+apr_pool_t *modperl_sv2pool(pTHX_ SV *obj)
+{
+ char *classname;
+
+ if (!(SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVMG))) {
+ return NULL;
+ }
+
+ classname = SvCLASS(obj);
+
+ if (*classname != 'A') {
+ return NULL;
+ }
+
+ if (strnEQ(classname, "APR::", 5)) {
+ classname += 5;
+ switch (*classname) {
+ case 'P':
+ if (strEQ(classname, "Pool")) {
+ return (apr_pool_t *)SvObjIV(obj);
+ }
+ default:
+ return NULL;
+ };
+ }
+ else if (strnEQ(classname, "Apache::", 8)) {
+ classname += 8;
+ switch (*classname) {
+ case 'R':
+ if (strEQ(classname, "RequestRec")) {
+ return ((request_rec *)SvObjIV(obj))->pool;
+ }
+ default:
+ return NULL;
+ };
+ }
+
+ return NULL;
+}
+
char *modperl_apr_strerror(apr_status_t rv)
{
dTHX;
1.11 +8 -0 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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- modperl_util.h 2001/04/25 05:27:17 1.10
+++ modperl_util.h 2001/04/28 22:35:20 1.11
@@ -14,11 +14,19 @@
# define strncaseEQ(s1,s2,l) (!strncasecmp(s1,s2,l))
#endif
+#ifndef SvCLASS
+#define SvCLASS(o) HvNAME(SvSTASH(SvRV(o)))
+#endif
+
+#define SvObjIV(o) SvIV((SV*)SvRV(o))
+
MP_INLINE request_rec *modperl_sv2request_rec(pTHX_ SV *sv);
MP_INLINE SV *modperl_newSVsv_obj(pTHX_ SV *stashsv, SV *obj);
MP_INLINE SV *modperl_ptr2obj(pTHX_ char *classname, void *ptr);
+
+apr_pool_t *modperl_sv2pool(pTHX_ SV *obj);
#define modperl_bless_request_rec(r) \
modperl_ptr2obj("Apache", r)
1.1 modperl-2.0/t/response/TestAPI/uri.pm
Index: uri.pm
===================================================================
package TestAPI::uri;
use strict;
use warnings FATAL => 'all';
use Apache::URI ();
use Apache::RequestUtil ();
use Apache::Test;
my $location = '/' . __PACKAGE__;
sub handler {
my $r = shift;
plan $r, tests => 12;
$r->args('query');
my $uri = $r->parsed_uri;
ok $uri->isa('Apache::URI');
ok $uri->path =~ m:^$location:;
my $up = $uri->unparse;
ok $up =~ m:^$location:;
my $parsed = Apache::URI->parse($r);
ok $parsed->isa('Apache::URI');
$up = $parsed->unparse;
ok $up =~ m:$location:;
ok $parsed->query eq $r->args;
my $path = '/foo/bar';
$parsed->path($path);
ok $parsed->path eq $path;
my $newr = Apache::RequestRec->new($r->connection);
my $url_string = "$path?query";
$newr->parse_uri($url_string);
ok $newr->uri eq $path;
ok $newr->args eq 'query';
ok $newr->parsed_uri->path eq $path;
ok $newr->parsed_uri->query eq 'query';
my @c = qw(one two three);
$url_string = join '%20', @c;
Apache::unescape_url($url_string);
ok $url_string eq "@c";
Apache::OK;
}
1;
1.7 +4 -0 modperl-2.0/xs/modperl_xs_util.h
Index: modperl_xs_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/modperl_xs_util.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- modperl_xs_util.h 2001/04/19 21:26:40 1.6
+++ modperl_xs_util.h 2001/04/28 22:35:21 1.7
@@ -1,6 +1,10 @@
#ifndef MODPERL_XS_H
#define MODPERL_XS_H
+#define mpxs_Apache__RequestRec_pool(r) r->pool
+#define mpxs_Apache__Connection_pool(c) c->pool
+#define mpxs_Apache__URI_pool(u) ((modperl_uri_t *)u)->pool
+
#ifndef dAX
# define dAX I32 ax = mark - PL_stack_base + 1
#endif
1.1 modperl-2.0/xs/Apache/URI/Apache__URI.h
Index: Apache__URI.h
===================================================================
/* subclass uri_components */
typedef struct {
uri_components uri;
apr_pool_t *pool;
char *path_info;
} modperl_uri_t;
static MP_INLINE
modperl_uri_t *mpxs_uri_new(apr_pool_t *p)
{
modperl_uri_t *uri = (modperl_uri_t *)apr_pcalloc(p, sizeof(*uri));
uri->pool = p;
return uri;
}
static MP_INLINE
uri_components *mpxs_Apache__RequestRec_parsed_uri(request_rec *r)
{
modperl_uri_t *uri = mpxs_uri_new(r->pool);
uri->uri = r->parsed_uri;
uri->path_info = r->path_info;
return (uri_components *)uri;
}
static MP_INLINE
char *mpxs_ap_unparse_uri_components(pTHX_
uri_components *uptr,
unsigned flags)
{
return ap_unparse_uri_components(((modperl_uri_t *)uptr)->pool,
uptr, flags);
}
static MP_INLINE
uri_components *mpxs_ap_parse_uri_components(pTHX_
SV *classname,
SV *obj,
const char *uri_string)
{
request_rec *r = NULL;
apr_pool_t *p = modperl_sv2pool(aTHX_ obj);
modperl_uri_t *uri = mpxs_uri_new(p);
if (!p) {
return NULL;
}
if (!uri_string) {
r = mp_xs_sv2_r(obj);
uri_string = ap_construct_url(r->pool, r->uri, r);
}
(void)ap_parse_uri_components(p, uri_string, &uri->uri);
if (r) {
uri->uri.query = r->args;
}
return (uri_components *)uri;
}
static MP_INLINE int mpxs_ap_unescape_url(pTHX_ SV *url)
{
int status;
STRLEN n_a;
(void)SvPV_force(url, n_a);
if ((status = ap_unescape_url(SvPVX(url))) == OK) {
SvCUR_set(url, strlen(SvPVX(url)));
}
return status;
}
1.15 +8 -4 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.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- apache_functions.map 2001/04/28 19:29:44 1.14
+++ apache_functions.map 2001/04/28 22:35:23 1.15
@@ -243,11 +243,15 @@
ap_os_escape_path
MODULE=Apache::URI PACKAGE=guess
+ ap_unescape_url | mpxs_ | SV *:url
ap_parse_uri
- ap_parse_uri_components
- ap_parse_hostinfo_components
- ap_unescape_url
- ap_unparse_uri_components
+!ap_parse_hostinfo_components
+ uri_components *:ap_parse_uri_components | mpxs_ | \
+ SV *:classname, SV *:p, uri=NULL | parse
+ ap_unparse_uri_components | mpxs_ | \
+ uptr, flags=UNP_OMITPASSWORD | unparse
+PACKAGE=Apache::RequestRec
+ mpxs_Apache__RequestRec_parsed_uri
!MODULE=Apache::StringUtil PACKAGE=guess
ap_checkmask
