joes 2004/07/24 14:09:19
Modified: glue/perl/docs Cookie.pod
glue/perl/xsbuilder apreq_xs_postperl.h apreq_xs_tables.h
glue/perl/xsbuilder/Apache/Cookie Apache__Cookie.h Cookie_pm
glue/perl/xsbuilder/maps apreq_structures.map
apreq_types.map
src apreq_cookie.c
Log:
Test::Inline rocks. Lots of api bugs uncovered:
1) -secure => 1 is ignored by apreq_cookie_set_attr.
2) $jar->pool causes segfaults in CGI mode (probably not fixable, so ->pool
needs to go).
3)$jar->env causes segfaults in CGI mode (but this is fixable, so it should
be ok now).
4) $cookie->secure was missing from the API because unsigned wasn't included
in apreq_types.map.
$cookie->secure also needed to be exposed in apreq_structures.map.
5) scalar $jar->get(missing-cookie) was broken because the S2C macro wasn't
checking for NULL returns of apr_table_get.
I also generally replaced all ST(0) reassignments with a proper stack PUSHs.
Mainly to start the process of replacing all the unmaintainable
APREQ_XS_DEFINE* macro junk in apreq_xs_*.h
Revision Changes Path
1.2 +116 -45 httpd-apreq-2/glue/perl/docs/Cookie.pod
Index: Cookie.pod
===================================================================
RCS file: /home/cvs/httpd-apreq-2/glue/perl/docs/Cookie.pod,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Cookie.pod 22 Jul 2004 03:07:44 -0000 1.1
+++ Cookie.pod 24 Jul 2004 21:09:18 -0000 1.2
@@ -5,16 +5,16 @@
=for testing
- use Apache2;
- use Apache::Cookie;
- use APR::Pool;
- $r = APR::Pool->new;
- $j = Apache::Cookie::Jar->new($r);
- $j->cookies->{foo} = Apache::Cookie->new($r, name => "foo", value => "1");
- $j->cookies->add( Apache::Cookie->new($r, name => "bar", value => "2") );
- # We must disable bake and bake2 in the api tests,
- # since they write directly to fd 1 via apr_file_write().
- *Apache::Cookie::bake = *Apache::Cookie::bake2 =
*Apache::Cookie::as_string;
+ use Apache2;
+ use Apache::Cookie;
+ use APR::Pool;
+ $r = APR::Pool->new;
+ $j = Apache::Cookie::Jar->new($r);
+ $j->cookies->{foo} = Apache::Cookie->new($r, name => "foo", value =>
"1");
+ $j->cookies->add( Apache::Cookie->new($r, name => "bar", value => "2") );
+ # We must disable bake and bake2 in the api tests,
+ # since they write directly to fd 1 via apr_file_write().
+ *Apache::Cookie::bake = *Apache::Cookie::bake2 =
*Apache::Cookie::as_string;
@@ -71,22 +71,28 @@
Class method that retrieves the parsed cookie jar from the current
-environment.
-
+environment. The optional VALUE_CLASS => $cookie_class instructs
+the jar to bless any returned cookies into $cookie_class, instead
+of Apache::Cookie. This feature could be most useful in situations
+where C<Apache::Cookie::thaw> is unable to correctly interpret an incoming
+cookie's serialization. Users can simply override C<thaw> in a subclass
+and pass that subclass's name in the VALUE_CLASS argument.
=for example begin
- {
+ {
package FOO;
@ISA= 'Apache::Cookie';
- }
- my $jar = Apache::Cookie::Jar->new($r, VALUE_CLASS => "FOO");
+ }
+ my $jar = Apache::Cookie::Jar->new($r, VALUE_CLASS => "FOO");
+ ok $jar->cookies("foo")->isa("FOO");
+ ok $jar->cookies->{bar}->isa("FOO");
=for example end
=for example_testing
- ok $jar->isa("Apache::Cookie::Jar");
- ok $jar->cookies("foo")->isa("FOO");
- ok $jar->cookies->{foo}->isa("FOO");
+ ok $jar->isa("Apache::Cookie::Jar");
+ $jar->cookies->do(sub { ok $_[1]->isa("FOO"); });
+ map { ok $_->isa("FOO") } values %{$jar->cookies};
@@ -126,7 +132,6 @@
=for example end
-
=for example_testing
ok @cookies == 2;
ok $_ -> name eq "foo" for $cookie, @cookies;
@@ -149,10 +154,13 @@
eval { @cookies = $j->cookies("foo") }; # croaks
ok [EMAIL PROTECTED]>isa("Apache::Cookie::Jar::Error");
$j->status(0);
- ok $j->status == 0;
=for example end
+=for example_testing
+ @cookies = $j->cookies("foo");
+ ok $j->status == 0;
+
=head2 env
As a class method C<< Apache::Cookie::Jar->env >> returns
@@ -160,16 +168,14 @@
As an object method, C<< $jar->env >> returns the environment
object which first created the $jar (via C<new>).
-=for example
- ok Apache::Cookie::Jar->env eq ref $j->env;
-
+=for example begin
-=head2 pool
+ ok $j->env->isa(Apache::Cookie::Jar->env);
-The pool associated with the current environment.
+=for example end
-=for example
- ok $j->pool->isa("APR::Pool");
+=for example_testing
+ ok (Apache::Cookie::Jar->env eq "APR::Pool");
@@ -183,7 +189,9 @@
Just like CGI::Cookie::new, but requires an I<Apache> request object:
- my $cookie = Apache::Cookie->new($r,
+=for example begin
+
+ $cookie = Apache::Cookie->new($r,
-name => 'foo',
-value => 'bar',
-expires => '+3M',
@@ -192,6 +200,15 @@
-secure => 1
);
+=for example end
+
+=for example_testing
+ ok $cookie->name eq "foo";
+ ok $cookie->value eq "bar";
+ ok $cookie->domain eq ".capricorn.com";
+ ok $cookie->path eq "/cgi-bin/database";
+ ok $cookie->secure == 1;
+
The C<-value> attribute may be either an arrayref, a hashref, or
an object with a C<freeze> method. The <freeze> method must serialize
the object in a manner compatible with the "value" portion of the
@@ -203,8 +220,15 @@
Format the cookie object as a string:
- #same as $cookie->bake
- $r->headers_out->add("Set-Cookie" => $cookie->as_string);
+=for example begin
+
+ print $cookie->as_string;
+
+
+=end example begin
+
+=for example_testing
+ ok substr($_STDOUT_, 0, 8) eq "foo=bar;";
=head2 name
@@ -213,6 +237,7 @@
my $name = $cookie->name;
+
=head2 value
Get the value of the cookie:
@@ -224,30 +249,48 @@
C<freeze> method, one way to reconstitute the object is by subclassing
Apache::Cookie with a package that provides the associated C<thaw> sub:
- package My::Cookie;
- use base 'Apache::Cookie';
- sub thaw { ... }
- bless $cookie, __PACKAGE__;
+=for example begin
+ {
+ package My::COOKIE;
+ @ISA = 'Apache::Cookie';
+ sub thaw { my $val = shift->raw_value; $val =~ tr/a-z/A-Z/; $val }
+ }
+
+ bless $cookie, "My::COOKIE";
+
+ ok ($cookie->value eq "BAR");
+
+=for example end
+
- my $obj = $cookie->value; # same as $cookie->thaw($cookie->raw_value);
=head2 raw_value
Gets the raw (opaque) value string as it appears in the incoming
-"Cookie" header.
+"Cookie" header. The quote-operator for Apache::Cookie is
+overloaded to run this method whenever a cookie appears in quotes.
+
+=for example begin
+
+ ok $cookie->raw_value eq "bar";
+ ok "$cookie" eq "bar";
+=for example end
+
+=for example_testing
+ # run the example, don't just compile it
=head2 bake
-Add a I<Set-Cookie> header to the outgoing headers table.
+Adds a I<Set-Cookie> header to the outgoing headers table.
$cookie->bake;
=head2 bake2
-Add a I<Set-Cookie2> header to the outgoing headers table.
+Adds a I<Set-Cookie2> header to the outgoing headers table.
$cookie->bake2;
@@ -256,30 +299,57 @@
Get or set the domain for the cookie:
- my $domain = $cookie->domain;
- $cookie->domain(".cp.net");
+=for example begin
+
+ $domain = $cookie->domain;
+ $cookie->domain(".cp.net");
+
+=for example end
+
+=for example_testing
+ ok $domain eq ".capricorn.com";
+ ok $cookie->domain eq ".cp.net";
+
=head2 path
Get or set the path for the cookie:
- my $path = $cookie->path;
- $cookie->path("/");
+=for example begin
+
+ $path = $cookie->path;
+ $cookie->path("/");
+
+=for example end
+
+=for example_testing
+ ok $path eq "/cgi-bin/database";
+ ok $cookie->path eq "/";
+
=head2 expires
Get or set the expire time for the cookie:
+=for example begin
+
my $expires = $cookie->expires;
$cookie->expires("+3h");
+=for example end
+
+
=head2 secure
Get or set the secure flag for the cookie:
+=for example begin
+
my $secure = $cookie->secure;
$cookie->secure(1);
+=for example end
+
=head2 fetch
@@ -287,15 +357,16 @@
=for example begin
- my $cookies = Apache::Cookie->fetch($r); #hash ref
+ my $cookies = Apache::Cookie->fetch($r); # Apache::Cookie::Table ref
my %cookies = Apache::Cookie->fetch($r);
=for example end
=for example_testing
-# ok "foobar" eq join "", keys %$cookies;
-# ok 12 == join "", sort map {$_->value} values %cookies;
+ ok "foobarfoo" eq join "", keys %$cookies;
+ ok "barfoo" eq join "", sort keys %cookies; # %cookies lost original foo
cookie
+ ok 23 == join "", sort map "$_", values %cookies;
1.43 +16 -16 httpd-apreq-2/glue/perl/xsbuilder/apreq_xs_postperl.h
Index: apreq_xs_postperl.h
===================================================================
RCS file: /home/cvs/httpd-apreq-2/glue/perl/xsbuilder/apreq_xs_postperl.h,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- apreq_xs_postperl.h 22 Jul 2004 03:29:08 -0000 1.42
+++ apreq_xs_postperl.h 24 Jul 2004 21:09:18 -0000 1.43
@@ -70,6 +70,7 @@
Perl_croak(aTHX_ "panic: unsupported SV type: %d", SvTYPE(sv));
}
}
+
return NULL;
}
@@ -144,13 +145,14 @@
* base class for Apache::Request and Apache::Cookie::Jar objects.
*/
#define APREQ_XS_DEFINE_ENV(type) \
-APR_INLINE \
static XS(apreq_xs_##type##_env) \
{ \
char *class = NULL; \
- dMARK; dAX; \
- \
+ dXSARGS; \
+ SV *sv, *obj; \
/* map environment to package */ \
+ if (items != 1) \
+ Perl_croak(aTHX_ "Usage: $obj->env"); \
\
if (strcmp(apreq_env_name, "APACHE2") == 0) \
class = "Apache::RequestRec"; \
@@ -163,18 +165,14 @@
if (class == NULL) \
XSRETURN(0); \
\
+ XSprePUSH; \
if (SvROK(ST(0))) { \
- SV *sv = apreq_xs_find_obj(aTHX_ ST(0), #type); \
- void *env = apreq_xs_sv2env(sv); \
- \
- if (env) \
- ST(0) = sv_2mortal(sv_setref_pv(newSV(0), \
- class, env)); \
- else \
- ST(0) = &PL_sv_undef; \
+ obj = apreq_xs_find_obj(aTHX_ ST(0), #type); \
+ sv = apreq_xs_perl_sv2env(aTHX_ obj); \
+ XPUSHs(sv_2mortal(newRV_inc(SvRV(sv)))); \
} \
else \
- ST(0) = sv_2mortal(newSVpv(class, 0)); \
+ XPUSHs(sv_2mortal(newSVpv(class, 0))); \
\
XSRETURN(1); \
}
@@ -242,8 +240,8 @@
key = SvPVbyte(ST(2), klen); \
val = SvPVbyte(ST(3), vlen); \
t = apreq_make_##type(pool, key, klen, val, vlen); \
- \
- ST(0) = sv_2mortal(apreq_xs_##type##2sv(t,class,ST(1))); \
+ XSprePUSH; \
+ XPUSHs(sv_2mortal(apreq_xs_##type##2sv(t,class,ST(1)))); \
XSRETURN(1); \
}
@@ -276,14 +274,16 @@
{ \
dXSARGS; \
void *env; \
- SV *obj; \
+ SV *obj, *sv; \
\
if (items != 1 || !SvROK(ST(0))) \
Perl_croak(aTHX_ "Usage: $obj->pool()"); \
obj = apreq_xs_find_obj(aTHX_ ST(0), #attr); \
env = apreq_xs_sv2env(obj); \
- ST(0) = sv_2mortal(sv_setref_pv(newSV(0), "APR::Pool", \
+ sv = sv_2mortal(sv_setref_pv(newSV(0), "APR::Pool", \
apreq_env_pool(env))); \
+ XSprePUSH; \
+ XPUSHs(sv); \
XSRETURN(1); \
}
1.29 +8 -5 httpd-apreq-2/glue/perl/xsbuilder/apreq_xs_tables.h
Index: apreq_xs_tables.h
===================================================================
RCS file: /home/cvs/httpd-apreq-2/glue/perl/xsbuilder/apreq_xs_tables.h,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- apreq_xs_tables.h 23 Jul 2004 07:21:14 -0000 1.28
+++ apreq_xs_tables.h 24 Jul 2004 21:09:18 -0000 1.29
@@ -113,7 +113,8 @@
env = obj->env; \
t = apr_table_make(apreq_env_pool(env), APREQ_NELTS); \
sv = apreq_xs_table2sv(t, class, ST(1), pkg); \
- ST(0) = sv_2mortal(sv); \
+ XSprePUSH; \
+ PUSHs(sv); \
XSRETURN(1); \
}
@@ -270,7 +271,7 @@
if (items == 1) { \
apr_table_t *t = apreq_xs_##attr##_sv2table(obj); \
if (t != NULL) \
-
XPUSHs(sv_2mortal(apreq_xs_table2sv(t,class,d.parent,d.pkg))); \
+
PUSHs(sv_2mortal(apreq_xs_table2sv(t,class,d.parent,d.pkg))); \
PUTBACK; \
break; \
} \
@@ -278,7 +279,7 @@
RETVAL = apreq_xs_##attr##_##type(obj, key); \
\
if (RETVAL && (COND)) \
- XPUSHs(sv_2mortal( \
+ PUSHs(sv_2mortal( \
apreq_xs_##type##2sv(RETVAL,d.pkg,d.parent))); \
\
default: \
@@ -326,7 +327,8 @@
apreq_##type##_t *RETVAL = apreq_value_to_##type( \
apreq_strtoval(val)); \
sv = apreq_xs_##type##2sv(RETVAL, pkg, parent); \
- ST(0) = sv_2mortal(sv); \
+ XSprePUSH; \
+ XPUSHs(sv_2mortal(sv)); \
XSRETURN(1); \
} \
else \
@@ -360,7 +362,8 @@
} \
idx = SvCUR(obj)++; \
sv = newSVpv(te[idx].key, 0); \
- ST(0) = sv_2mortal(sv); \
+ XSprePUSH; \
+ PUSHs(sv_2mortal(sv)); \
XSRETURN(1); \
}
1.31 +20 -13
httpd-apreq-2/glue/perl/xsbuilder/Apache/Cookie/Apache__Cookie.h
Index: Apache__Cookie.h
===================================================================
RCS file:
/home/cvs/httpd-apreq-2/glue/perl/xsbuilder/Apache/Cookie/Apache__Cookie.h,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- Apache__Cookie.h 22 Jul 2004 03:29:08 -0000 1.30
+++ Apache__Cookie.h 24 Jul 2004 21:09:18 -0000 1.31
@@ -72,7 +72,7 @@
/* GET macros */
-#define S2C(s) apreq_value_to_cookie(apreq_strtoval(s))
+#define S2C(s) (s ? apreq_value_to_cookie(apreq_strtoval(s)) : NULL)
#define apreq_xs_jar_push(sv,d,key) apreq_xs_push(jar,sv,d,key)
#define apreq_xs_table_push(sv,d,key) apreq_xs_push(table,sv,d,key)
#define apreq_xs_jar_sv2table(sv) ((apreq_jar_t *)SvIVX(sv))->cookies
@@ -118,7 +118,8 @@
sv = NEWSV(0, apreq_serialize_cookie(NULL, 0, c));
SvCUR(sv) = apreq_serialize_cookie(SvPVX(sv), SvLEN(sv), c);
SvPOK_on(sv);
- ST(0) = sv_2mortal(sv);
+ XSprePUSH;
+ XPUSHs(sv_2mortal(sv));
XSRETURN(1);
}
@@ -201,6 +202,7 @@
dXSARGS;
STRLEN slen;
const char *src;
+ SV *sv;
if (items != 1)
Perl_croak(aTHX_ "Usage: encode($string)");
@@ -209,11 +211,13 @@
if (src == NULL)
XSRETURN_UNDEF;
- ST(0) = sv_newmortal();
- SvUPGRADE(ST(0), SVt_PV);
- SvGROW(ST(0), 3 * slen + 1);
- SvCUR(ST(0)) = apreq_encode(SvPVX(ST(0)), src, slen);
- SvPOK_on(ST(0));
+ sv = sv_newmortal();
+ SvUPGRADE(sv, SVt_PV);
+ SvGROW(sv, 3 * slen + 1);
+ SvCUR(sv) = apreq_encode(SvPVX(sv), src, slen);
+ SvPOK_on(sv);
+ XSprePUSH;
+ XPUSHs(sv);
XSRETURN(1);
}
@@ -223,6 +227,7 @@
STRLEN slen;
apr_ssize_t len;
const char *src;
+ SV *sv;
if (items != 1)
Perl_croak(aTHX_ "Usage: decode($string)");
@@ -231,13 +236,15 @@
if (src == NULL)
XSRETURN_UNDEF;
- ST(0) = sv_newmortal();
- SvUPGRADE(ST(0), SVt_PV);
- SvGROW(ST(0), slen + 1);
- len = apreq_decode(SvPVX(ST(0)), src, slen);
+ sv = sv_newmortal();
+ SvUPGRADE(sv, SVt_PV);
+ SvGROW(sv, slen + 1);
+ len = apreq_decode(SvPVX(sv), src, slen);
if (len < 0)
XSRETURN_UNDEF;
- SvCUR_set(ST(0),len);
- SvPOK_on(ST(0));
+ SvCUR_set(sv,len);
+ SvPOK_on(sv);
+ XSprePUSH;
+ XPUSHs(sv);
XSRETURN(1);
}
1.22 +6 -2 httpd-apreq-2/glue/perl/xsbuilder/Apache/Cookie/Cookie_pm
Index: Cookie_pm
===================================================================
RCS file:
/home/cvs/httpd-apreq-2/glue/perl/xsbuilder/Apache/Cookie/Cookie_pm,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- Cookie_pm 22 Jul 2004 03:29:08 -0000 1.21
+++ Cookie_pm 24 Jul 2004 21:09:18 -0000 1.22
@@ -15,6 +15,9 @@
package Apache::Cookie::Error;
push our(@ISA), qw/APR::Error Apache::Cookie/;
+package Apache::Cookie::Jar::Error;
+push our(@ISA), qw/APR::Error Apache::Cookie::Jar/;
+
package Apache::Cookie::Jar;
sub new {
@@ -27,6 +30,7 @@
package Apache::Cookie;
+use overload '""' => sub { shift->raw_value };
sub jar {
my ($self, $env) = @_;
@@ -87,9 +91,9 @@
}
sub thaw {
- my $self = shift;
- my @rv = map decode($_), split /&/, $self->raw_value;
+ my @rv = map decode($_), split /&/, shift->raw_value;
return wantarray ? @rv : $rv[0];
}
sub value { shift->thaw }
+
1.9 +1 -1
httpd-apreq-2/glue/perl/xsbuilder/maps/apreq_structures.map
Index: apreq_structures.map
===================================================================
RCS file:
/home/cvs/httpd-apreq-2/glue/perl/xsbuilder/maps/apreq_structures.map,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- apreq_structures.map 29 Jun 2004 18:34:48 -0000 1.8
+++ apreq_structures.map 24 Jul 2004 21:09:18 -0000 1.9
@@ -27,7 +27,7 @@
path
domain
port
-! secure
+ secure
comment
commentURL
! max_age
1.6 +1 -0 httpd-apreq-2/glue/perl/xsbuilder/maps/apreq_types.map
Index: apreq_types.map
===================================================================
RCS file: /home/cvs/httpd-apreq-2/glue/perl/xsbuilder/maps/apreq_types.map,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- apreq_types.map 28 Jun 2004 21:58:15 -0000 1.5
+++ apreq_types.map 24 Jul 2004 21:09:18 -0000 1.6
@@ -8,6 +8,7 @@
void | VOID
void * | PTR
const void * | PTR
+unsigned | UV
#data structure stuff
struct apr_pool_t | APR::Pool | T_POOLOBJ
1.28 +2 -1 httpd-apreq-2/src/apreq_cookie.c
Index: apreq_cookie.c
===================================================================
RCS file: /home/cvs/httpd-apreq-2/src/apreq_cookie.c,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- apreq_cookie.c 18 Jul 2004 03:54:20 -0000 1.27
+++ apreq_cookie.c 24 Jul 2004 21:09:18 -0000 1.28
@@ -143,7 +143,8 @@
break;
case 's':
- c->secure = (!strncasecmp("on",val,vlen));
+ c->secure = (vlen > 0 && *val != '0'
+ && strncasecmp("off",val,vlen));
return APR_SUCCESS;
};
