perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From do...@apache.org
Subject cvs commit: modperl-2.0/xs/Apache/RequestIO Apache__RequestIO.h
Date Mon, 30 Apr 2001 07:17:50 GMT
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)
   
  
  
  

Mime
View raw message