httpd-apreq-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From j...@apache.org
Subject svn commit: r154775 - in httpd/apreq/branches/multi-env-unstable: glue/perl/ glue/perl/lib/ glue/perl/lib/Apache/ glue/perl/t/apreq/ glue/perl/t/response/TestApReq/ glue/perl/xsbuilder/ glue/perl/xsbuilder/APR/Request/ glue/perl/xsbuilder/APR/Request/Cookie/ glue/perl/xsbuilder/APR/Request/Param/ glue/perl/xsbuilder/maps/ library/
Date Tue, 22 Feb 2005 03:27:41 GMT
Author: joes
Date: Mon Feb 21 19:27:38 2005
New Revision: 154775

URL: http://svn.apache.org/viewcvs?view=rev&rev=154775
Log:

Get the glue/perl/t/apreq/cookie tests passing again on *nix.





Added:
    httpd/apreq/branches/multi-env-unstable/glue/perl/lib/
    httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/
    httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Cookie.pm
    httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Request.pm
Modified:
    httpd/apreq/branches/multi-env-unstable/glue/perl/Makefile.PL
    httpd/apreq/branches/multi-env-unstable/glue/perl/t/apreq/cookie.t
    httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/cookie.pm
    httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/inherit.pm
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.pm
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.xs
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Param/Param.xs
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.pm
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.xs
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_postperl.h
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_tables.h
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_functions.map
    httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_types.map
    httpd/apreq/branches/multi-env-unstable/library/module.c

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/Makefile.PL
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/Makefile.PL?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/Makefile.PL (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/Makefile.PL Mon Feb 21 19:27:38 2005
@@ -514,13 +514,13 @@
 sub typemap_code
 {
     {
-        T_SUBCLASS => {
+           T_SUBCLASS  => {
                           INPUT => <<'EOT',
     if (SvROK($arg) || !sv_derived_from($arg, \"$Package\"))
         Perl_croak(aTHX_ \"Usage: argument is not a subclass of $Package\");
     $var = SvPV_nolen($arg)
 EOT
-                          },
+                           },
 
         T_APREQ_COOKIE  => {
                             INPUT  => '$var = apreq_xs_sv2cookie(aTHX_ $arg)',
@@ -528,51 +528,40 @@
                             OUTPUT => '$arg = apreq_xs_cookie2sv(aTHX_ $var, class, parent);',
                             c2perl => 'apreq_xs_cookie2sv(aTHX_ ptr, class, parent)',
                            },
+
         T_APREQ_PARAM   => {
                             INPUT  => '$var = apreq_xs_sv2param(aTHX_ $arg)',
                             perl2c => 'apreq_xs_sv2param(aTHX_ sv)',
                             OUTPUT => '$arg = apreq_xs_param2sv(aTHX_ $var, class, parent);',
                             c2perl => 'apreq_xs_param2sv(aTHX_ ptr, class, parent)',
                            },
-        T_APREQ_HANDLE => {
-                            INPUT  => '$var = apreq_xs_perl2c(aTHX_ $arg, \"r\")',
-                            perl2c => 'apreq_xs_perl2c(aTHX_ sv, \"r\")',
-                            c2perl => 'sv_setref_pv(newSV(0), class, ptr)',
-                            OUTPUT => <<'EOT',
-    $arg = sv_setref_pv(newSV(0), class, $var);
-    if (sv_derived_from($arg, \"${ntype}\")) {
-        SV *parent = ST(1);
-        SV *rv = SvRV($arg);
-        sv_magic(rv, parent, PERL_MAGIC_ext, Nullch, 0);
-    }
-    else
-        Perl_croak(aTHX_ \"Usage: target class %s isn't derived from ${ntype}\", class);
-EOT
+
+         T_APREQ_HANDLE => {
+                            INPUT  => '$var = apreq_xs_sv2handle(aTHX_ $arg)',
+                            perl2c => 'apreq_xs_sv2handle(aTHX_ sv)',
+                            c2perl => 'apreq_xs_handle2sv(aTHX_ ptr, class, parent)',
+                            OUTPUT => '$arg = apreq_xs_handle2sv(aTHX_ $var, class, parent);',
                            },
-        T_APREQ_HANDLE_APACHE2 => {
-                            INPUT  => '$var = apreq_xs_perl2c(aTHX_ $arg, \"r\")',
+
+     T_APREQ_HANDLE_CGI => {
+                            INPUT  => '$var = apreq_xs_sv2handle(aTHX_ $arg)',
+                            OUTPUT => '$arg = apreq_xs_handle2sv(aTHX_ $var, class, SvRV(ST(1)));'
+                           },
+
+ T_APREQ_HANDLE_APACHE2 => {
+                            INPUT  => '$var = apreq_xs_sv2handle(aTHX_ $arg)',
                             OUTPUT => <<'EOT',
-    $arg = sv_setref_pv(newSV(0), class, $var);
-    if (sv_derived_from($arg, \"${ntype}\")) {
-        SV *parent = SvRV(ST(1)); /* r's SV */
-        SV *rv = SvRV($arg);
-        sv_magic(rv, parent, PERL_MAGIC_ext, Nullch, -1);
-        SvMAGIC(rv)->mg_ptr = (void *)r;
-    }
-    else
-        Perl_croak(aTHX_ \"Usage: target class %s isn't derived from ${ntype}\", class);
+    $arg = apreq_xs_handle2sv(aTHX_ $var, class, SvRV(ST(1)));
+    SvMAGIC(SvRV($arg))->mg_ptr = (void *)r;
 EOT
                            },
- T_APREQ_COOKIE_VERSION => {
-                            INPUT  => '$var = ((apreq_cookie_version_t)SvTRUE($arg))',
-                            OUTPUT => '$arg = boolSV((bool)$var);',
-                           },
-    T_APREQ_ERROR => {
-                          INPUT => '$var = (HV *)SvRV($arg)',
-                          OUTPUT => '$arg = sv_bless(newRV_noinc((SV*)$var), gv_stashpvn(\"${ntype}\",
sizeof(\"${ntype}\") - 1, FALSE);'
-                     },
 
-        T_HASHOBJ       => {
+          T_APREQ_ERROR => {
+                             INPUT => '$var = (HV *)SvRV($arg)',
+                            OUTPUT => '$arg = sv_bless(newRV_noinc((SV*)$var), gv_stashpvn(\"${ntype}\",
sizeof(\"${ntype}\") - 1, FALSE);'
+                           },
+
+              T_HASHOBJ => {
                             INPUT => <<'EOT', # '$var = modperl_hash_tied_object(aTHX_
\"${ntype}\", $arg)'
     if (sv_derived_from($arg, \"${ntype}\")) {
         if (SVt_PVHV == SvTYPE(SvRV($arg))) {
@@ -603,7 +592,7 @@
     }
 EOT
 
-                            OUTPUT => <<'EOT', # '$arg = modperl_hash_tie(aTHX_
\"${ntype}\", $arg, $var);'
+                 OUTPUT => <<'EOT', # '$arg = modperl_hash_tie(aTHX_ \"${ntype}\",
$arg, $var);'
   {
     SV *hv = (SV*)newHV();
     SV *rsv = $arg;

Added: httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Cookie.pm
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Cookie.pm?view=auto&rev=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Cookie.pm (added)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Cookie.pm Mon Feb 21 19:27:38
2005
@@ -0,0 +1,86 @@
+package Apache::Cookie;
+use Apache::RequestRec;
+use APR::Request::Cookie;
+use APR::Request::Apache2;
+use APR::Request qw/encode decode/;
+
+push our @ISA, "APR::Request::Cookie";
+
+sub new {
+    my ($class, $r, %attrs) = @_;
+    my $name  = delete $attrs{name};
+    my $value = delete $attrs{value};
+    $name     = delete $attrs{-name}  unless defined $name;
+    $value    = delete $attrs{-value} unless defined $value;
+    return unless defined $name and defined $value;
+
+    my $cookie = $class->make($r->pool, $name,
+                              $class->freeze($value));
+
+    while(my ($k, $v) = each %attrs) {
+        $k =~ s/^-//;
+        $cookie->$k($v);
+    }
+    $r = APR::Request::Apache2->new($r) unless $r->isa("APR::Request");
+    $cookie->bind_handle($r);
+    $cookie;
+}
+
+
+sub fetch {
+    my $class = shift;
+    my $req = shift;
+    unless (defined $req) {
+        my $usage = 'Usage: Apache::Cookie->fetch($r): missing argument $r';
+        $req = eval {Apache->request} or die <<EOD;
+$usage: attempt to fetch global Apache->request failed: $@.
+EOD
+    }
+    $req = APR::Request::Apache2->new($req) unless $req->isa("APR::Request");
+    my $jar = $req->jar or return;
+    $jar->cookie_class(__PACKAGE__);
+    return wantarray ? %$jar : $jar;
+}
+
+
+sub set_attr {
+    my ($cookie, %attrs) = @_;
+    while (my ($k, $v) = each %attrs) {
+        $k =~ s/^-//;
+        $cookie->$k($v);
+    }
+}
+
+sub freeze {
+    my ($class, $value) = @_;
+    die "Usage: Apache::Cookie->freeze($value)" unless @_ == 2;
+
+    if (not ref $value) {
+        return encode($value);
+    }
+    elsif (UNIVERSAL::isa($value, "ARRAY")) {
+        return join '&', map encode($_), @$value;
+    }
+    elsif (UNIVERSAL::isa($value, "HASH")) {
+        return join '&', map encode($_), %$value;
+    }
+
+    die "Can't freeze reference: $value";
+}
+
+sub thaw {
+    my $self = shift;
+    my @rv = split /&/, @_ ? shift : "$self";
+    return wantarray ? map decode($_), @rv : decode($rv[0]);
+}
+
+sub value {
+    return shift->thaw;
+}
+
+package Apache::Cookie::Jar;
+use APR::Request::Apache2;
+push our @ISA, qw/APR::Request::Apache2/;
+sub cookies { shift->jar(@_) }
+
+1;

Added: httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Request.pm
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Request.pm?view=auto&rev=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Request.pm (added)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/lib/Apache/Request.pm Mon Feb 21 19:27:38
2005
@@ -0,0 +1,10 @@
+package Apache::Request;
+use APR::Request::Apache2;
+use Apache::RequestRec;
+push our @ISA, qw/Apache::RequestRec APR::Request::Apache2/;
+
+package Apache::Upload;
+use APR::Request::Param;
+push our @ISA, qw/APR::Request::Param/;
+
+1;

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/t/apreq/cookie.t
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/t/apreq/cookie.t?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/t/apreq/cookie.t (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/t/apreq/cookie.t Mon Feb 21 19:27:38
2005
@@ -6,7 +6,7 @@
 use Apache::TestUtil;
 use Apache::TestRequest qw(GET_BODY GET_HEAD);
 
-plan tests => 7, under_construction; # have_lwp
+plan tests => 7, have_lwp;#under_construction; # have_lwp
 
 require HTTP::Cookies;
 

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/cookie.pm
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/cookie.pm?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/cookie.pm (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/cookie.pm Mon Feb
21 19:27:38 2005
@@ -17,25 +17,27 @@
     my %cookies = Apache::Cookie->fetch($r);
 
     $r->content_type('text/plain');
-    my $test = $req->param('test');
-    my $key  = $req->param('key');
+    my $test = $req->APR::Request::args('test');
+    my $key  = $req->APR::Request::args('key');
 
     if ($key and $cookies{$key}) {
         if ($test eq "bake") {
+            $cookies{$key}->tainted(0);
             $cookies{$key}->bake;
         }
         elsif ($test eq "bake2") {
+            $cookies{$key}->tainted(0);
             $cookies{$key}->bake2;
         }
         $r->print($cookies{$key}->value);
     }
     else {
         my @expires;
-        @expires = ("expires", $req->param('expires')) if $req->param('expires');
+        @expires = ("expires", $req->APR::Request::args('expires')) if $req->APR::Request::args('expires');
         my $cookie = Apache::Cookie->new($r, name => "foo",
                                             value => "bar", @expires);
         if ($test eq "bake") {
-            $cookie->bake;
+            $cookie->bake($req);
         }
         elsif ($test eq "bake2") {
             $cookie->set_attr(version => 1);

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/inherit.pm
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/inherit.pm?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/inherit.pm (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/t/response/TestApReq/inherit.pm Mon
Feb 21 19:27:38 2005
@@ -13,9 +13,8 @@
     die "Wrong package: ", ref $r unless $r->isa('TestApReq::inherit');
     $r->content_type('text/plain');
     # look for segfault when $r->isa("Apache::Request")
-    my $j = Apache::Cookie::Jar->new($r);
 
-    my $req = bless { r => $r, j => $j };
+    my $req = bless { r => $r };
     $req->printf("method => %s\n", $req->method);
     $req->printf("cookie => %s\n", $req->cookies("apache")->as_string);
     return 0;

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.pm
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.pm?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.pm
(original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.pm
Mon Feb 21 19:27:38 2005
@@ -1 +1,20 @@
 use APR::Request;
+
+sub new {
+    my ($class, $pool, %attrs) = @_;
+    my $name  = delete $attrs{name};
+    my $value = delete $attrs{value};
+    $name     = delete $attrs{-name}  unless defined $name;
+    $value    = delete $attrs{-value} unless defined $value;
+    return unless defined $name and defined $value;
+
+    my $cookie = $class->make($pool, $name, $class->freeze($value));
+    while(my ($k, $v) = each %attrs) {
+        $k =~ s/^-//;
+        $cookie->$k($v);
+    }
+    return $cookie;
+}
+
+sub freeze { return $_[1] }
+sub thaw { return shift->value }

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.xs
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.xs?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.xs
(original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Cookie/Cookie.xs
Mon Feb 21 19:27:38 2005
@@ -1,45 +1,5 @@
 #include "apreq_xs_tables.h"
 #define TABLE_CLASS "APR::Request::Cookie::Table"
-#define COOKIE_CLASS "APR::Request::Cookie"
-#define ERROR_CLASS "APR::Request::Error"
-
-static APR_INLINE
-SV *apreq_xs_cookie2sv(pTHX_ apreq_cookie_t *c, const char *class, SV *parent)
-{
- 
-    SV *rv = sv_setref_pv(newSV(0), class, (void *)c);
-    sv_magic(SvRV(rv), parent, PERL_MAGIC_ext, Nullch, 0);
-    return rv;
-}
-
-static APR_INLINE
-apreq_cookie_t *apreq_xs_sv2cookie(pTHX_ SV *sv)
-{
-    IV iv = SvIVX(SvRV(sv));
-    return INT2PTR(apreq_cookie_t *, iv);
-}
-
-static APR_INLINE
-SV *apreq_xs_table2sv(pTHX_ const apr_table_t *t, const char *class, SV *parent,
-                      const char *cookie_class, I32 clen)
-{
-    SV *sv = (SV *)newHV();
-    SV *rv = sv_setref_pv(newSV(0), class, (void *)t);
-    sv_magic(SvRV(rv), parent, PERL_MAGIC_ext, cookie_class, clen);
-
-#if (PERL_VERSION >= 8) /* MAGIC ITERATOR requires 5.8 */
-
-    sv_magic(sv, NULL, PERL_MAGIC_ext, Nullch, -1);
-    SvMAGIC(sv)->mg_virtual = (MGVTBL *)&apreq_xs_table_magic;
-    SvMAGIC(sv)->mg_flags |= MGf_COPY;
-
-#endif
-
-    sv_magic(sv, rv, PERL_MAGIC_tied, Nullch, 0);
-    SvREFCNT_dec(rv); /* corrects SvREFCNT_inc(rv) implicit in sv_magic */
-
-    return sv_bless(newRV_noinc(sv), SvSTASH(SvRV(rv)));
-}
 
 static int apreq_xs_table_keys(void *data, const char *key, const char *val)
 {
@@ -81,8 +41,8 @@
         Perl_croak(aTHX_ "Usage: APR::Request::jar($req [,$name])");
 
     sv = ST(0);
-    obj = apreq_xs_find_obj(aTHX_ sv, "r");
-    iv = SvIVX(SvRV(obj));
+    obj = apreq_xs_sv2object(aTHX_ sv, HANDLE_CLASS, 'r');
+    iv = SvIVX(obj);
     req = INT2PTR(apreq_handle_t *, iv);
 
     if (items == 2 && GIMME_V == G_SCALAR) {
@@ -117,7 +77,7 @@
             XSRETURN_EMPTY;
 
         d.pkg = COOKIE_CLASS;
-        d.parent = SvRV(obj);
+        d.parent = obj;
 
         switch (GIMME_V) {
 
@@ -143,13 +103,12 @@
     }
 }
 
-
 static XS(apreq_xs_table_FETCH)
 {
     dXSARGS;
     const apr_table_t *t;
     const char *cookie_class;
-    SV *sv, *t_obj, *parent;
+    SV *sv, *obj, *parent;
     IV iv;
     MAGIC *mg;
 
@@ -159,15 +118,14 @@
 
     sv = ST(0);
 
-    t_obj = apreq_xs_find_obj(aTHX_ sv, "param");
-    iv = SvIVX(SvRV(t_obj));
+    obj = apreq_xs_sv2object(aTHX_ sv, TABLE_CLASS, 't');
+    iv = SvIVX(obj);
     t = INT2PTR(const apr_table_t *, iv);
 
-    mg = mg_find(SvRV(t_obj), PERL_MAGIC_ext);
+    mg = mg_find(obj, PERL_MAGIC_ext);
     cookie_class = mg->mg_ptr;
     parent = mg->mg_obj;
 
-
     if (GIMME_V == G_SCALAR) {
         IV idx;
         const char *key, *val;
@@ -175,7 +133,7 @@
         apr_table_entry_t *te;
         key = SvPV_nolen(ST(1));
 
-        idx = SvCUR(SvRV(t_obj));
+        idx = SvCUR(obj);
         arr = apr_table_elts(t);
         te  = (apr_table_entry_t *)arr->elts;
 
@@ -221,8 +179,7 @@
         Perl_croak(aTHX_ "Usage: $table->NEXTKEY($prev)");
 
     sv  = ST(0);
-    obj = apreq_xs_find_obj(aTHX_ sv, "param");
-    obj = SvRV(obj);
+    obj = apreq_xs_sv2object(aTHX_ sv, TABLE_CLASS, 't');
 
     iv = SvIVX(obj);
     t = INT2PTR(const apr_table_t *, iv);
@@ -349,6 +306,23 @@
   OUTPUT:
     RETVAL
 
+SV*
+bind_handle(cookie, req)
+    SV *cookie
+    SV *req
+  PREINIT:
+    MAGIC *mg;
+    SV *obj;
+  CODE:
+    obj = apreq_xs_sv2object(aTHX_ cookie, COOKIE_CLASS, 'c');
+    mg = mg_find(obj, PERL_MAGIC_ext);
+    req = apreq_xs_sv2object(aTHX_ req, HANDLE_CLASS, 'r');
+    RETVAL = newRV_noinc(mg->mg_obj);
+    SvREFCNT_inc(req);
+    mg->mg_obj = req;
+
+  OUTPUT:
+    RETVAL
 
 APR::Request::Cookie
 make(class, pool, name, val)
@@ -394,8 +368,8 @@
     APR::Request::Cookie::Table t
     char *newclass
   PREINIT:
-    SV *obj = apreq_xs_find_obj(aTHX_ ST(0), "table");
-    MAGIC *mg = mg_find(SvRV(obj), PERL_MAGIC_ext);
+    SV *obj = apreq_xs_sv2object(aTHX_ ST(0), TABLE_CLASS, 't');
+    MAGIC *mg = mg_find(obj, PERL_MAGIC_ext);
     char *curclass = mg->mg_ptr;
 
   CODE:

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Param/Param.xs
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Param/Param.xs?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Param/Param.xs
(original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Param/Param.xs
Mon Feb 21 19:27:38 2005
@@ -1,44 +1,6 @@
 #include "apreq_xs_tables.h"
 #define TABLE_CLASS "APR::Request::Param::Table"
-#define PARAM_CLASS "APR::Request::Param"
-#define ERROR_CLASS "APR::Request::Error"
 
-static APR_INLINE
-SV *apreq_xs_param2sv(pTHX_ apreq_param_t *p, const char *class, SV *parent)
-{
-    SV *rv = sv_setref_pv(newSV(0), class, (void *)p);
-    sv_magic(SvRV(rv), parent, PERL_MAGIC_ext, Nullch, 0);
-    return rv;
-}
-
-static APR_INLINE
-apreq_param_t *apreq_xs_sv2param(pTHX_ SV *sv)
-{
-    IV iv = SvIVX(SvRV(sv));
-    return INT2PTR(apreq_param_t *, iv);
-}
-
-static APR_INLINE
-SV *apreq_xs_table2sv(pTHX_ const apr_table_t *t, const char *class, SV *parent,
-                      const char *param_class, I32 plen)
-{
-    SV *sv = (SV *)newHV();
-    SV *rv = sv_setref_pv(newSV(0), class, (void *)t);
-    sv_magic(SvRV(rv), parent, PERL_MAGIC_ext, param_class, plen);
-
-#if (PERL_VERSION >= 8) /* MAGIC ITERATOR requires 5.8 */
-
-    sv_magic(sv, NULL, PERL_MAGIC_ext, Nullch, -1);
-    SvMAGIC(sv)->mg_virtual = (MGVTBL *)&apreq_xs_table_magic;
-    SvMAGIC(sv)->mg_flags |= MGf_COPY;
-
-#endif
-
-    sv_magic(sv, rv, PERL_MAGIC_tied, Nullch, 0);
-    SvREFCNT_dec(rv); /* corrects SvREFCNT_inc(rv) implicit in sv_magic */
-
-    return sv_bless(newRV_noinc(sv), SvSTASH(SvRV(rv)));
-}
 
 static int apreq_xs_table_keys(void *data, const char *key, const char *val)
 {
@@ -80,8 +42,8 @@
         Perl_croak(aTHX_ "Usage: APR::Request::args($req [,$name])");
 
     sv = ST(0);
-    obj = apreq_xs_find_obj(aTHX_ sv, "r");
-    iv = SvIVX(SvRV(obj));
+    obj = apreq_xs_sv2object(aTHX_ sv, HANDLE_CLASS, 'r');
+    iv = SvIVX(obj);
     req = INT2PTR(apreq_handle_t *, iv);
 
 
@@ -156,7 +118,7 @@
         Perl_croak(aTHX_ "Usage: APR::Request::body($req [,$name])");
 
     sv = ST(0);
-    obj = apreq_xs_find_obj(aTHX_ sv, "r");
+    obj = apreq_xs_sv2object(aTHX_ sv, HANDLE_CLASS, 'r');
     iv = SvIVX(SvRV(obj));
     req = INT2PTR(apreq_handle_t *, iv);
 
@@ -236,11 +198,11 @@
 
     sv = ST(0);
 
-    t_obj = apreq_xs_find_obj(aTHX_ sv, "param");
-    iv = SvIVX(SvRV(t_obj));
+    t_obj = apreq_xs_sv2object(aTHX_ sv, TABLE_CLASS, 't');
+    iv = SvIVX(t_obj);
     t = INT2PTR(const apr_table_t *, iv);
 
-    mg = mg_find(SvRV(t_obj), PERL_MAGIC_ext);
+    mg = mg_find(t_obj, PERL_MAGIC_ext);
     param_class = mg->mg_ptr;
     parent = mg->mg_obj;
 
@@ -252,7 +214,7 @@
         apr_table_entry_t *te;
         key = SvPV_nolen(ST(1));
 
-        idx = SvCUR(SvRV(t_obj));
+        idx = SvCUR(t_obj);
         arr = apr_table_elts(t);
         te  = (apr_table_entry_t *)arr->elts;
 
@@ -298,8 +260,7 @@
         Perl_croak(aTHX_ "Usage: " TABLE_CLASS "::NEXTKEY($table, $key)");
 
     sv  = ST(0);
-    obj = apreq_xs_find_obj(aTHX_ sv, "param");
-    obj = SvRV(obj);
+    obj = apreq_xs_sv2object(aTHX_ sv, TABLE_CLASS,'t');
 
     iv = SvIVX(obj);
     t = INT2PTR(const apr_table_t *, iv);
@@ -426,8 +387,8 @@
     APR::Request::Param::Table t
     char *newclass
   PREINIT:
-    SV *obj = apreq_xs_find_obj(aTHX_ ST(0), "table");
-    MAGIC *mg = mg_find(SvRV(obj), PERL_MAGIC_ext);
+    SV *obj = apreq_xs_sv2object(aTHX_ ST(0), TABLE_CLASS, 't');
+    MAGIC *mg = mg_find(obj, PERL_MAGIC_ext);
     char *curclass = mg->mg_ptr;
 
   CODE:

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.pm
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.pm?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.pm (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.pm Mon
Feb 21 19:27:38 2005
@@ -3,3 +3,13 @@
     require APR::Error;
     push our @ISA, qw/APR::Error APR::Request/;
 }
+
+sub import {
+    my $class = shift;
+    return unless @_;
+    my $pkg = caller;
+    no strict 'refs';
+    for (@_) {
+        *{"$pkg\::$_"} = *{"$class\::$_"};
+    }
+}

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.xs
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.xs?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.xs (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/APR/Request/Request.xs Mon
Feb 21 19:27:38 2005
@@ -11,16 +11,11 @@
     apreq_handle_t *req;
     apr_status_t s;
     const apr_table_t *t;
-    SV *sv, *obj;
-    IV iv;
 
-    if (items != 1 || !SvROK(ST(0)) || !sv_derived_from(ST(0), "APR::Request"))
+    if (items != 1 || !SvROK(ST(0)))
         Perl_croak(aTHX_ "Usage: APR::Request::parse($req)");
 
-    sv = ST(0);
-    obj = apreq_xs_find_obj(aTHX_ sv, "r");
-    iv = SvIVX(SvRV(obj));
-    req = INT2PTR(apreq_handle_t *, iv);
+    req = apreq_xs_sv2handle(aTHX_ ST(0));
 
     XSprePUSH;
     EXTEND(SP, 3);
@@ -30,11 +25,41 @@
     PUSHs(sv_2mortal(newSViv(s)));
     s = apreq_body(req, &t);
     PUSHs(sv_2mortal(newSViv(s)));
-
     PUTBACK;
 }
 
 MODULE = APR::Request     PACKAGE = APR::Request
+
+SV*
+encode(in)
+    SV *in
+  PREINIT:
+    STRLEN len;
+    char *src;
+  CODE:
+    src = SvPV(in, len);
+    RETVAL = newSV(3 * len);
+    SvCUR_set(RETVAL, apreq_encode(SvPVX(RETVAL), src, len));
+    SvPOK_on(RETVAL);
+
+  OUTPUT:
+    RETVAL
+
+SV*
+decode(in)
+    SV *in
+  PREINIT:
+    STRLEN len;
+    apr_size_t dlen;
+    char *src;
+  CODE:
+    src = SvPV(in, len);
+    RETVAL = newSV(len);
+    apreq_decode(SvPVX(RETVAL), &dlen, src, len); /*XXX needs error-handling */
+    SvCUR_set(RETVAL, dlen);
+    SvPOK_on(RETVAL);
+  OUTPUT:
+    RETVAL
 
 SV*
 read_limit(req, val=NULL)

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_postperl.h
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_postperl.h?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_postperl.h (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_postperl.h Mon Feb
21 19:27:38 2005
@@ -34,6 +34,10 @@
 typedef HV             apreq_xs_error_t;
 typedef char*          apreq_xs_subclass_t;
 
+#define HANDLE_CLASS "APR::Request"
+#define COOKIE_CLASS "APR::Request::Cookie"
+#define PARAM_CLASS  "APR::Request::Param"
+#define ERROR_CLASS  "APR::Request::Error"
 
 /**
  * @file apreq_xs_postperl.h
@@ -54,9 +58,9 @@
  * @return    Reference to the object.
  */
 APR_INLINE
-static SV *apreq_xs_find_obj(pTHX_ SV *in, const char *key)
+static SV *apreq_xs_find_obj(pTHX_ SV *in, const char key)
 {
-    const char altkey[] = { '_', key[0] };
+    const char altkey[] = { '_', key };
 
     while (in && SvROK(in)) {
         SV *sv = SvRV(in);
@@ -68,7 +72,7 @@
                in = mg->mg_obj;
                break;
             }
-            else if ((svp = hv_fetch((HV *)sv, key, 1, FALSE)) ||
+            else if ((svp = hv_fetch((HV *)sv, altkey+1, 1, FALSE)) ||
                      (svp = hv_fetch((HV *)sv, altkey, 2, FALSE)))
             {
                 in = *svp;
@@ -83,7 +87,7 @@
        }
     }
 
-    Perl_croak(aTHX_ "apreq_xs_find_obj: object `%s' not found", key);
+    Perl_croak(aTHX_ "apreq_xs_find_obj: object attr `%c' not found", key);
     return NULL;
 }
 
@@ -94,7 +98,7 @@
  * and produces a pointer to the object's C analog.
  */
 APR_INLINE
-static void *apreq_xs_perl2c(pTHX_ SV* in, const char *name)
+static void *apreq_xs_perl2c(pTHX_ SV* in, const char name)
 {
     SV *sv = apreq_xs_find_obj(aTHX_ in, name);
     IV iv = SvIVX(SvRV(sv));
@@ -112,22 +116,92 @@
     return NULL; /* not reached */
 }
 
+
+
+static APR_INLINE
+SV *apreq_xs_object2sv(pTHX_ void *ptr, const char *class, SV *parent, const char *base)
+{
+    SV *rv = sv_setref_pv(newSV(0), class, (void *)ptr);
+    sv_magic(SvRV(rv), parent, PERL_MAGIC_ext, Nullch, 0);
+    if (!sv_derived_from(rv, base))
+        croak("apreq_xs_object2sv failed: target class %s isn't derived from %s",
+              class, base);
+    return rv;
+}
+
+
+APR_INLINE
+static SV *apreq_xs_handle2sv(pTHX_ apreq_handle_t *req, 
+                              const char *class, SV *parent)
+{
+    return apreq_xs_object2sv(aTHX_ req, class, parent, HANDLE_CLASS);
+}
+
+APR_INLINE
+static SV *apreq_xs_param2sv(pTHX_ apreq_param_t *p, 
+                              const char *class, SV *parent)
+{
+    return apreq_xs_object2sv(aTHX_ p, class, parent, PARAM_CLASS);
+}
+
+APR_INLINE
+static SV *apreq_xs_cookie2sv(pTHX_ apreq_cookie_t *c, 
+                              const char *class, SV *parent)
+{
+    return apreq_xs_object2sv(aTHX_ c, class, parent, COOKIE_CLASS);
+}
+
+
 APR_INLINE
-static apreq_handle_t *apreq_xs_get_handle(pTHX_ SV *sv)
+static SV *apreq_xs_sv2object(pTHX_ SV *sv, const char *class, const char attr)
 {
-    MAGIC *mg = mg_find(SvRV(sv), PERL_MAGIC_ext);
-    SV *obj = apreq_xs_find_obj(aTHX_ mg->mg_obj, "r");
-    IV iv = SvIVX(SvRV(obj));
-    return INT2PTR(apreq_handle_t *,iv);
+    SV *obj;
+    MAGIC *mg;
+    sv = apreq_xs_find_obj(aTHX_ sv, attr);
+    if (sv_derived_from(sv, class)) {
+        return SvRV(sv);
+    }
+
+    /* check if parent (mg->mg_obj) is a handle */
+    if ((mg = mg_find(SvRV(sv), PERL_MAGIC_ext)) != NULL
+        && (obj = mg->mg_obj) != NULL
+        && SvOBJECT(obj))
+    {
+        sv = sv_2mortal(newRV_noinc(obj));
+        if (sv_derived_from(sv, class))
+            return obj;
+    }
+
+    Perl_croak(aTHX_ "apreq_xs_sv2object: %s object not found", class);
+    return NULL;
 }
 
 APR_INLINE
-static const apr_table_t *apreq_xs_get_table(pTHX_ SV *sv, const char *name)
+static apreq_handle_t *apreq_xs_sv2handle(pTHX_ SV *sv)
 {
-    SV *obj = apreq_xs_find_obj(aTHX_ sv, name);
-    IV iv = SvIVX(SvRV(obj));
-    return INT2PTR(apr_table_t *,iv);
+    SV *obj = apreq_xs_sv2object(aTHX_ sv, HANDLE_CLASS, 'r');
+    IV iv = SvIVX(obj);
+    return INT2PTR(apreq_handle_t *, iv);
 }
+
+
+static APR_INLINE
+apreq_param_t *apreq_xs_sv2param(pTHX_ SV *sv)
+{
+    SV *obj = apreq_xs_sv2object(aTHX_ sv, PARAM_CLASS, 'p');
+    IV iv = SvIVX(obj);
+    return INT2PTR(apreq_param_t *, iv);
+}
+
+static APR_INLINE
+apreq_cookie_t *apreq_xs_sv2cookie(pTHX_ SV *sv)
+{
+    SV *obj = apreq_xs_sv2object(aTHX_ sv, COOKIE_CLASS, 'c');
+    IV iv = SvIVX(obj);
+    return INT2PTR(apreq_cookie_t *, iv);
+}
+
+
 
 /** 
  * Searches a perl object ref with apreq_xs_find_obj

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_tables.h
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_tables.h?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_tables.h (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/apreq_xs_tables.h Mon Feb
21 19:27:38 2005
@@ -62,17 +62,14 @@
  * @param class Class perl object will be blessed and tied to.
  * @return Reference to a new TIEHASH object in class.
  */
-APR_INLINE
-static SV *apreq_xs_table_c2perl(pTHX_ void *obj, const char *name, I32 nlen,
-                                 const char *class, SV *parent, unsigned tainted)
+
+static APR_INLINE
+SV *apreq_xs_table2sv(pTHX_ const apr_table_t *t, const char *class, SV *parent,
+                      const char *value_class, I32 vclen)
 {
     SV *sv = (SV *)newHV();
-    /*upgrade ensures CUR and LEN are both 0 */
-    SV *rv = sv_setref_pv(newSV(0), class, obj);
-
-    sv_magic(SvRV(rv), parent, PERL_MAGIC_ext, name, nlen);
-    if (tainted)
-        SvTAINTED_on(SvRV(rv));
+    SV *rv = sv_setref_pv(newSV(0), class, (void *)t);
+    sv_magic(SvRV(rv), parent, PERL_MAGIC_ext, value_class, vclen);
 
 #if (PERL_VERSION >= 8) /* MAGIC ITERATOR requires 5.8 */
 

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_functions.map
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_functions.map?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_functions.map (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_functions.map Mon
Feb 21 19:27:38 2005
@@ -126,10 +126,10 @@
 
 
 #################### APR::Request::Cookie stuff ####################
-# | apreq_cookie_bake(c, req) | apreq_cookie_t *:c, apreq_handle_t *:req=apreq_xs_get_handle(aTHX_
ST(0))
 MODULE=APR::Request::Cookie PACKAGE=APR::Request::Cookie PREFIX=apreq_cookie_
-apreq_cookie_bake
-apreq_cookie_bake2
+apreq_cookie_bake | (c, req) | apreq_cookie_t *:c, req=apreq_xs_sv2handle(aTHX_ ST(0))
+apreq_cookie_bake2| (c, req) | apreq_cookie_t *:c, req=apreq_xs_sv2handle(aTHX_ ST(0))
+apreq_cookie_expires
 
 MODULE=APR::Request::Cookie PACKAGE=APR::Request PREFIX=APR__Request_
 DEFINE_jar | apreq_xs_jar |

Modified: httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_types.map
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_types.map?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_types.map (original)
+++ httpd/apreq/branches/multi-env-unstable/glue/perl/xsbuilder/maps/apreq_types.map Mon Feb
21 19:27:38 2005
@@ -18,12 +18,12 @@
 struct apr_table_t          | APR::Table | T_HASHOBJ
 struct apr_bucket_brigade   | APR::Brigade
 
-struct apreq_param_t        | APR::Request::Param | T_APREQ_PARAM
-struct apreq_cookie_t       | APR::Request::Cookie | T_APREQ_COOKIE
+struct apreq_param_t        | APR::Request::Param | T_APREQ_PARAM | param
+struct apreq_cookie_t       | APR::Request::Cookie | T_APREQ_COOKIE | cookie
 
 struct apreq_handle_t         | APR::Request          | T_APREQ_HANDLE | req
 struct apreq_xs_handle_apache2_t | APR::Request::Apache2 | T_APREQ_HANDLE_APACHE2
-struct apreq_xs_handle_cgi_t     | APR::Request::CGI     | T_APREQ_HANDLE
+struct apreq_xs_handle_cgi_t     | APR::Request::CGI     | T_APREQ_HANDLE_CGI
 struct apreq_xs_error_t       | APR::Request::Error   | T_APREQ_ERROR
 struct apreq_xs_cookie_table_t | APR::Request::Cookie::Table | T_HASHOBJ
 struct apreq_xs_param_table_t | APR::Request::Param::Table | T_HASHOBJ

Modified: httpd/apreq/branches/multi-env-unstable/library/module.c
URL: http://svn.apache.org/viewcvs/httpd/apreq/branches/multi-env-unstable/library/module.c?view=diff&r1=154774&r2=154775
==============================================================================
--- httpd/apreq/branches/multi-env-unstable/library/module.c (original)
+++ httpd/apreq/branches/multi-env-unstable/library/module.c Mon Feb 21 19:27:38 2005
@@ -52,7 +52,7 @@
 
 
 APREQ_DECLARE(apr_status_t) apreq_cookie_bake(const apreq_cookie_t *c,
-                                              apreq_handle_t *env)
+                                              apreq_handle_t *req)
 {
     char s[APREQ_COOKIE_MAX_LENGTH];
     int len;
@@ -64,11 +64,11 @@
     if (len >= APREQ_COOKIE_MAX_LENGTH)
         return APREQ_ERROR_OVERLIMIT;
 
-    return apreq_header_out(env, "Set-Cookie", s);
+    return apreq_header_out(req, "Set-Cookie", s);
 }
 
 APREQ_DECLARE(apr_status_t) apreq_cookie_bake2(const apreq_cookie_t *c,
-                                               apreq_handle_t *env)
+                                               apreq_handle_t *req)
 {
     char s[APREQ_COOKIE_MAX_LENGTH];
     int len;
@@ -84,7 +84,7 @@
     if (len >= APREQ_COOKIE_MAX_LENGTH)
         return APREQ_ERROR_OVERLIMIT;
 
-    return apreq_header_out(env, "Set-Cookie2", s);
+    return apreq_header_out(req, "Set-Cookie2", s);
 }
 
 



Mime
View raw message