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: [EMAIL PROTECTED]
+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);
}
