dougm 01/04/30 00:17:50
Modified: lib/ModPerl WrapXS.pm
src/modules/perl mod_perl.h modperl_util.c modperl_util.h
xs typemap
xs/Apache/RequestIO Apache__RequestIO.h
Added: t/response/TestAPI r_subclass.pm
Log:
support subclassing of Apache::RequestRec
Revision Changes Path
1.11 +6 -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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- WrapXS.pm 2001/04/28 23:03:07 1.10
+++ WrapXS.pm 2001/04/30 07:17:45 1.11
@@ -467,6 +467,10 @@
EOF
}
+my %typemap = (
+ 'Apache::RequestRec' => 'T_APACHEOBJ',
+);
+
sub write_typemap {
my $self = shift;
my $typemap = $self->typemap;
@@ -481,7 +485,8 @@
next if $seen{$type}++ || $typemap->special($class);
if ($class =~ /::/) {
- print $fh "$class\tT_PTROBJ\n";
+ my $typemap = $typemap{$class} || 'T_PTROBJ';
+ print $fh "$class\t$typemap\n";
}
else {
print $fh "$type\tT_$class\n";
1.31 +2 -0 modperl-2.0/src/modules/perl/mod_perl.h
Index: mod_perl.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.h,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- mod_perl.h 2001/04/30 04:38:35 1.30
+++ mod_perl.h 2001/04/30 07:17:46 1.31
@@ -49,4 +49,6 @@
*/
#define MP_CODE_ATTRS(cv) (CvXSUBANY((CV*)cv).any_i32)
+#define MgTypeExt(mg) (mg->mg_type == '~')
+
#endif /* MOD_PERL_H */
1.11 +77 -4 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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- modperl_util.c 2001/04/28 22:35:20 1.10
+++ modperl_util.c 2001/04/30 07:17:46 1.11
@@ -25,15 +25,88 @@
return TRUE;
}
+static SV *modperl_hv_request_find(pTHX_ SV *in, char *classname, CV *cv)
+{
+ static char *r_keys[] = { "r", "_r", NULL };
+ HV *hv = (HV *)SvRV(in);
+ SV *sv = Nullsv;
+ int i;
+
+ for (i=0; r_keys[i]; i++) {
+ int klen = i + 1; /* assumes r_keys[] will never change */
+ SV **svp;
+
+ if ((svp = hv_fetch(hv, r_keys[i], klen, FALSE)) && (sv = *svp)) {
+ if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) {
+ /* dig deeper */
+ return modperl_hv_request_find(aTHX_ sv, classname, cv);
+ }
+ break;
+ }
+ }
+
+ if (!sv) {
+ Perl_croak(aTHX_
+ "method `%s' invoked by a `%s' object with no `r' key!",
+ cv ? GvNAME(CvGV(cv)) : "unknown",
+ HvNAME(SvSTASH(SvRV(in))));
+ }
+
+ return SvROK(sv) ? SvRV(sv) : sv;
+}
+
MP_INLINE request_rec *modperl_sv2request_rec(pTHX_ SV *sv)
+{
+ return modperl_xs_sv2request_rec(aTHX_ sv, NULL, Nullcv);
+}
+
+request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
{
- request_rec *r = NULL;
+ SV *sv = Nullsv;
+ MAGIC *mg;
- if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG)) {
- r = (request_rec *)SvIV((SV*)SvRV(sv));
+ if (in == &PL_sv_undef) {
+ return NULL;
+ }
+
+ if (SvROK(in)) {
+ SV *rv = (SV*)SvRV(in);
+
+ switch (SvTYPE(rv)) {
+ case SVt_PVMG:
+ sv = rv;
+ break;
+ case SVt_PVHV:
+ sv = modperl_hv_request_find(aTHX_ in, classname, cv);
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
+ SvTYPE(rv));
+ }
+ }
+
+ if (!sv) {
+ request_rec *r = NULL;
+ (void)modperl_tls_get_request_rec(&r);
+
+ if (!r) {
+ Perl_croak(aTHX_
+ "Apache->%s called without setting Apache->request!",
+ cv ? GvNAME(CvGV(cv)) : "unknown");
+ }
+
+ return r;
+ }
+
+ /* XXX: not checking sv_derived_from(sv, classname); for speed */
+ if ((mg = SvMAGIC(sv))) {
+ return MgTypeExt(mg) ? (request_rec *)mg->mg_ptr : NULL;
+ }
+ else {
+ return (request_rec *)SvIV(sv);
}
- return r;
+ return NULL;
}
MP_INLINE SV *modperl_newSVsv_obj(pTHX_ SV *stashsv, SV *obj)
1.13 +2 -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.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- modperl_util.h 2001/04/28 23:05:53 1.12
+++ modperl_util.h 2001/04/30 07:17:46 1.13
@@ -22,6 +22,8 @@
MP_INLINE request_rec *modperl_sv2request_rec(pTHX_ SV *sv);
+request_rec *modperl_xs_sv2request_rec(pTHX_ SV *sv, char *classname, CV *cv);
+
MP_INLINE SV *modperl_newSVsv_obj(pTHX_ SV *stashsv, SV *obj);
MP_INLINE SV *modperl_ptr2obj(pTHX_ char *classname, void *ptr);
1.1 modperl-2.0/t/response/TestAPI/r_subclass.pm
Index: r_subclass.pm
===================================================================
package TestAPI::r_subclass;
use strict;
use warnings FATAL => 'all';
our @ISA = qw(Apache::RequestRec);
use Apache::Test;
sub new {
my $class = shift;
my $r = shift;
bless { r => $r }, $class;
}
my $location = '/' . __PACKAGE__;
sub handler {
my $r = __PACKAGE__->new(shift);
plan $r, tests => 4;
ok $r->uri eq $location;
ok ((bless { r => $r })->uri eq $location); #nested
eval { (bless {})->uri };
ok $@ =~ /no .* key/;
eval { (bless [])->uri };
ok $@ =~ /unsupported/;
Apache::OK;
}
1;
1.3 +9 -0 modperl-2.0/xs/typemap
Index: typemap
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/typemap,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- typemap 2001/04/28 23:03:08 1.2
+++ typemap 2001/04/30 07:17:48 1.3
@@ -5,11 +5,20 @@
######################################################################
OUTPUT
+T_APACHEOBJ
+ sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+
T_VPTR
sv_setiv($arg, PTR2IV($var));
######################################################################
INPUT
+T_APACHEOBJ
+ $var = modperl_xs_sv2request_rec(aTHX_ $arg, \"$ntype\", cv)
+
+T_APACHEREF
+ $var = modperl_xs_sv2request_rec(aTHX_ $arg, \"$ntype\", cv)
+
T_VPTR
$var = INT2PTR($type,SvIV(SvROK($arg) ? SvRV($arg) : $arg))
1.7 +4 -0 modperl-2.0/xs/Apache/RequestIO/Apache__RequestIO.h
Index: Apache__RequestIO.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/Apache/RequestIO/Apache__RequestIO.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- Apache__RequestIO.h 2001/04/28 19:10:44 1.6
+++ Apache__RequestIO.h 2001/04/30 07:17:49 1.7
@@ -1,3 +1,7 @@
+/* XXX: should be part of generation */
+#undef mp_xs_sv2_r
+#define mp_xs_sv2_r(sv) modperl_sv2request_rec(aTHX_ sv)
+
#define mpxs_Apache__RequestRec_TIEHANDLE(stashsv, sv) \
modperl_newSVsv_obj(aTHX_ stashsv, sv)
