CGI-Apache2-Wrapper
view release on metacpan or search on metacpan
Build.PL
Changes
lib/CGI/Apache2/Wrapper.pm
lib/CGI/Apache2/Wrapper/Cookie.pm
lib/CGI/Apache2/Wrapper/Upload.pm
Makefile.PL
MANIFEST This list of files
META.yml
README
t/cgi/cookie.t
t/cgi/cookie2.t
t/cgi/param.t
t/cgi/extra.t
t/cgi/misc.t
author:
- 'Randy Kobes <r.kobes@uwinnipeg.ca>'
requires:
File::Spec: 0.8
Apache2::Request: 0
Apache2::RequestRec: 0
provides:
CGI::Apache2::Wrapper:
file: lib/CGI/Apache2/Wrapper.pm
version: 0.215
CGI::Apache2::Wrapper::Cookie:
file: lib/CGI/Apache2/Wrapper/Cookie.pm
version: 0.215
CGI::Apache2::Wrapper::Upload:
file: lib/CGI/Apache2/Wrapper/Upload.pm
version: 0.215
distribution_type: module
no_index:
file:
- t/response/TestCGI/basic.pm
- t/response/TestCGI/cookie.pm
- t/response/TestCGI/cookie2.pm
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
require Apache2::Response;
require Apache2::RequestRec;
require Apache2::RequestUtil;
require Apache2::Connection;
require Apache2::Access;
require Apache2::URI;
require Apache2::Log;
require APR::URI;
require APR::Pool;
require Apache2::Request;
require CGI::Apache2::Wrapper::Cookie;
require CGI::Apache2::Wrapper::Upload;
$MOD_PERL = 2;
}
else {
die qq{mod_perl 2 required};
}
}
else {
die qq{Must be running under mod_perl};
}
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
my $self = shift;
my $req = $self->{'.req'};
$self->{'.req'} = shift if @_;
return $req;
}
sub cookies {
my $self = shift;
my $cookies = $self->{'.cookies'};
return $cookies if (defined $cookies);
my %cookies = Apache2::Cookie->fetch($self->r);
$self->{'.cookies'} = %cookies ? \%cookies : undef;
return $self->{'.cookies'};
}
sub uploads {
my ($self, $name) = @_;
my $tmpfhs = $self->{'.tmpfhs'}->{$name};
return $tmpfhs if (defined $tmpfhs and ref($tmpfhs) eq 'ARRAY');
my @u = $self->req->upload($name);
return unless @u;
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
}
}
my $r = $self->r;
unless (defined $header_extra and ref($header_extra) eq 'HASH') {
$r->content_type('text/html');
return '';
}
my $content_type = delete $header_extra->{'Content-Type'} || 'text/html';
$r->content_type($content_type);
foreach my $key (keys %$header_extra) {
if ($key =~ /Set-Cookie/i) {
my $cookie = $header_extra->{$key};
if ($cookie) {
my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ?
@{$cookie} : $cookie;
foreach my $c (@cookie) {
my $cs = (UNIVERSAL::isa($c,'CGI::Cookie') or
UNIVERSAL::isa($c, 'CGI::Apache2::Wrapper::Cookie') or
UNIVERSAL::isa($c, 'Apache2::Cookie')) ?
$c->as_string : $c;
$r->err_headers_out->add($key => $cs);
}
}
}
else {
$r->err_headers_out->add($key => $header_extra->{$key});
}
}
return '';
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
$rv .= '?' . $self->query_string;
}
return $rv;
}
sub self_url {
return shift->url('-path_info' => 1, '-query' => 1);
}
# Apache2::Cookie
sub cookie {
my $self = shift;
my ($name, $value, %args);
if (@_) {
if (scalar @_ == 1) {
$name = shift;
}
else {
%args = @_;
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
}
unless (defined($value)) {
my $cookies = $self->cookies;
return () unless $cookies;
return keys %{$cookies} unless $name;
return () unless $cookies->{$name};
return $cookies->{$name}->value
if defined($name) && $name ne '';
}
return undef unless defined($name) && $name ne ''; # this is an error
my $cookie = CGI::Apache2::Wrapper::Cookie->new($self->r, %args);
return $cookie;
}
# Apache2::Upload
sub upload {
my ($self, $name) = @_;
return unless $name;
my $tmpfhs = $self->uploads($name);
return unless (defined $tmpfhs and ref($tmpfhs) eq 'ARRAY');
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
=item * my $url = $cgi-E<gt>self_url;
This generates the complete url, and is a shortcut for
I<my $url = $cgi-E<gt>url(-query =E<gt> 1, -path =E<gt> 1);>. Using the
example described in the I<url> options, this would lead to
I<http://localhost:8529/TestCGI/extra/path/info?opening=hello;closing=goodbye>.
=back
=head2 Apache2::Cookie
A new cookie can be created as
my $c = $cgi->cookie(-name => 'foo',
-value => 'bar',
-expires => '+3M',
-domain => '.capricorn.com',
-path => '/cgi-bin/database',
-secure => 1
);
which is an object of the L<CGI::Apache2::Wrapper::Cookie>
class. The arguments accepted are
=over
=item * I<-name>
This is the name of the cookie (required)
=item * I<-value>
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
A value of an existing cookie can be retrieved by
calling I<cookie> without the I<value> parameter:
my $value = $cgi->cookie(-name => 'fred');
A list of all cookie names can be obtained by calling
I<cookie> without any arguments:
my @names = $cgi->cookie();
See also L<CGI::Apache2::Wrapper::Cookie> for a
L<CGI::Cookie>-compatible interface to cookies.
=head2 Apache2::Upload
Uploads can be handled with the I<upload> method:
my $fh = $cgi->upload('filename');
which returns a file handle that can be used to access the
uploaded file. If there are multiple upload fields, calling
I<upload> in a list context:
lib/CGI/Apache2/Wrapper/Cookie.pm view on Meta::CPAN
package CGI::Apache2::Wrapper::Cookie;
use strict;
use warnings;
our $VERSION = '0.215';
our $MOD_PERL;
use overload '""' => sub { shift->as_string() }, fallback => 1;
sub new {
my ($class, $r, %args) = @_;
unless (defined $r and ref($r) and ref($r) eq 'Apache2::RequestRec') {
die qq{Must pass in an Apache2::RequestRec object \$r};
}
if ($ENV{USE_CGI_PM}) {
require CGI::Cookie;
return CGI::Cookie->new($r);
}
if (exists $ENV{MOD_PERL}) {
if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
require Apache2::RequestRec;
require Apache2::Request;
require Apache2::Cookie;
$MOD_PERL = 2;
}
else {
die qq{mod_perl 2 required};
}
}
else {
die qq{Must be running under mod_perl};
}
unless ($args{path} || $args{'-path'}) {
$args{path} = '/';
}
my $cookie = Apache2::Cookie->new($r, %args);
die qq{Creation of Apache2::Cookie failed}
unless ($cookie and ref($cookie) eq 'Apache2::Cookie');
my $self = {};
bless $self, ref $class || $class;
$self->r($r) unless $self->r;
$self->{cookie} = $cookie;
return $self;
}
sub r {
my $self = shift;
lib/CGI/Apache2/Wrapper/Cookie.pm view on Meta::CPAN
$self->{'.r'} = shift if @_;
return $r;
}
sub fetch {
my ($class, $r) = @_;
unless (defined $r and ref($r) and ref($r) eq 'Apache2::RequestRec') {
die qq{Must pass in an Apache2::RequestRec object \$r};
}
if ($ENV{USE_CGI_PM}) {
require CGI::Cookie;
return CGI::Cookie->fetch($r);
}
if (exists $ENV{MOD_PERL}) {
if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
require Apache2::RequestRec;
require Apache2::Request;
require Apache2::Cookie;
$MOD_PERL = 2;
}
else {
die qq{mod_perl 2 required};
}
}
else {
die qq{Must be running under mod_perl};
}
my %cookies = Apache2::Cookie->fetch($r);
return wantarray ? %cookies : \%cookies;
}
sub cookie {
my $self = shift;
return $self->{cookie};
}
sub name {
my $self = shift;
die qq{Apache2::Cookie doesn't support setting "name"} if @_;
return $self->cookie->name;
}
sub value {
my $self = shift;
die qq{Apache2::Cookie doesn't support setting "value"} if @_;
return $self->cookie->value;
}
sub path {
my ($self, $x) = @_;
if (defined $x) {
$self->cookie->path($x);
return $x;
}
else {
lib/CGI/Apache2/Wrapper/Cookie.pm view on Meta::CPAN
$self->cookie->secure($x);
return $x;
}
else {
return $self->cookie->secure;
}
}
sub expires {
my ($self, $x) = @_;
die qq{Apache2::Cookie currently demands an argument to "expires"}
unless (defined $x);
$self->cookie->expires($x);
}
sub httponly {
die qq{Apache2::Cookie currently doesn't support "httponly"};
}
sub as_string {
return shift->cookie->as_string;
}
sub bake {
my $self = shift;
return $self->cookie->bake($self->r);
}
1;
__END__
=head1 NAME
CGI::Apache2::Wrapper::Cookie - cookies via libapreq2
=head1 SYNOPSIS
use CGI::Apache2::Wrapper::Cookie;
sub handler {
my $r = shift;
# create a new Cookie and add it to the headers
my $cookie = CGI::Apache2::Wrapper::Cookie->new($r,
-name=>'ID',
-value=>123456);
$cookie->bake();
# fetch existing cookies
my %cookies = CGI::Apache2::Wrapper::Cookie->fetch($r);
my $id = $cookies{'ID'}->value;
return Apache2::Const::OK;
}
=head1 DESCRIPTION
This module provides a wrapper around L<Apache2::Cookie>. Some
methods are overridden in order to provide a L<CGI::Cookie>-compatible
interface.
Cookies are created with the I<new> method:
my $c = CGI::Apache2::Wrapper::Cookie->new($r,
-name => 'foo',
-value => 'bar',
-expires => '+3M',
-domain => '.capricorn.com',
-path => '/cgi-bin/database',
-secure => 1
);
with a mandatory first argument of the L<Apache2::RequestRec> object I<$r>.
lib/CGI/Apache2/Wrapper/Cookie.pm view on Meta::CPAN
If set to a true value, this instructs the
browser to return the cookie only when a cryptographic protocol is in use.
=back
After creation, cookies can be sent to the browser in the appropriate
header by I<$c-E<gt>bake();>.
Existing cookies can be fetched with
I<%cookies = CGI::Apache2::Wrapper::Cookie-E<gt>fetch($r);>,
which requires a mandatory argument of the L<Apache2::RequestRec>
object I<$r>. In a scalar context, this returns a hash reference.
The keys of the hash are the values of the I<name> of the Cookie,
while the values are the corresponding I<CGI::Apache2::Wrapper::Cookie>
object.
=head1 Methods
Available methods are
=over
=item * I<new>
my $c = CGI::Apache2::Wrapper::Cookie->new($r, %args);
This creates a new cookie. Mandatory arguments are the
L<Apache2::RequestRec> object I<$r>, as well as the I<name>
and I<value> specified in I<%args>.
=item * I<name>
my $name = $c->name();
This gets the cookie name.
lib/CGI/Apache2/Wrapper/Cookie.pm view on Meta::CPAN
my $secure = $c->secure();
my $new_secure_setting = $c->secure(1);
This gets or sets the security setting of the cookie.
=item * I<expires>
$c->expires('+3M');
This sets the expires setting of the cookie. In the current
behaviour of L<Apache2::Cookie>, this requires a mandatory
setting, and doesn't return anything.
=item * I<bake>
$c->bake();
This will send the cookie to the browser by adding the stringified
version of the cookie to the I<Set-Cookie> field of the HTTP
header.
=item * I<fetch>
%cookies = CGI::Apache2::Wrapper::Cookie->fetch($r);
This fetches existing cookies, and
requires a mandatory argument of the L<Apache2::RequestRec>
object I<$r>. In a scalar context, this returns a hash reference.
The keys of the hash are the values of the I<name> of the Cookie,
while the values are the corresponding I<CGI::Apache2::Wrapper::Cookie>
object.
=back
=head1 SEE ALSO
L<CGI>, L<CGI::Cookie>,
L<Apache2::Cookie>, and L<CGI::Apache2::Wrapper>.
Development of this package takes place at
L<http://cpan-search.svn.sourceforge.net/viewvc/cpan-search/CGI-Apache2-Wrapper/>.
=head1 SUPPORT
You can find documentation for this module with the perldoc command:
perldoc CGI::Apache2::Wrapper::Cookie
You can also look for information at:
=over 4
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/CGI-Apache2-Wrapper>
=item * CPAN::Forum: Discussion forum
lib/CGI/Apache2/Wrapper/Cookie.pm view on Meta::CPAN
=item * UWinnipeg CPAN Search
L<http://cpan.uwinnipeg.ca/dist/CGI-Apache2-Wrapper>
=back
=head1 ENVIRONMENT VARIABLES
If the I<USE_CGI_PM> environment variable is set, the
I<new> method will return a L<CGI::Cookie> object,
while I<fetch> will return the corresponding
cookies using L<CGI::Cookie>.
=head1 COPYRIGHT
This software is copyright 2007 by Randy Kobes
E<lt>r.kobes@uwinnipeg.caE<gt>. Use and
redistribution are under the same terms as Perl itself;
see L<http://www.perl.com/pub/a/language/misc/Artistic.html>.
=cut
t/cgi/cookie.t view on Meta::CPAN
my $test = 'new';
my $value = 'new';
ok t_cmp(GET_BODY("$location?test=new"),
$value,
$test);
}
{
my $test = '';
my $value = 'foo=; path=/quux; domain=example.com';
my ($header) = (GET_HEAD("$location?test=$test")
=~ /^#Set-Cookie:\s+(.+)/m) ;
ok t_cmp($header,
$value,
$test);
}
{
my $test = 'bake';
my $value = 'foo=bake; path=/quux; domain=example.com';
my ($header) = (GET_HEAD("$location?test=bake")
=~ /^#Set-Cookie:\s+(.+)/m) ;
ok t_cmp($header,
$value,
$test);
}
{
my $test = 'new';
my $value = 'new';
ok t_cmp(GET_BODY("$location?test=new;expires=%2B3M"),
$value,
$test);
}
{
my $test = 'netscape';
my $key = 'apache';
my $value = 'ok';
my $cookie = qq{$key=$value};
ok t_cmp(GET_BODY("$location?test=$test&key=$key", Cookie => $cookie),
$value,
$test);
}
{
my $test = 'rfc';
my $key = 'apache';
my $value = 'ok';
my $cookie = qq{\$Version="1"; $key="$value"; \$Path="$location"};
ok t_cmp(GET_BODY("$location?test=$test&key=$key", Cookie => $cookie),
qq{"$value"},
$test);
}
{
my $test = 'encoded value with space';
my $key = 'apache';
my $value = 'okie dokie';
my $cookie = "$key=" . join '',
map {/ / ? '+' : sprintf '%%%.2X', ord} split //, $value;
ok t_cmp(GET_BODY("$location?test=$test&key=$key", Cookie => $cookie),
$value,
$test);
}
{
my $test = 'bake';
my $key = 'apache';
my $value = 'ok';
my $cookie = "$key=$value";
my ($header) = GET_HEAD("$location?test=$test&key=$key",
Cookie => $cookie) =~ /^#Set-Cookie:\s+(.+)/m;
ok t_cmp($header, $cookie, $test);
}
{
my $test = 'cookies';
my $key = 'first';
my $cookie1 = qq{\$Version="1"; one="1"};
my $cookie2 = qq{\$Version="1"; two="2"};
my $cookie3 = qq{\$Version="1"; three="3"};
my $value = qq{"1"};
my $str = GET_BODY("$location?test=$test&key=$key",
Cookie => $cookie1,
Cookie => $cookie2,
Cookie => $cookie3,
);
ok t_cmp($str, $value, $test);
}
{
my $test = 'cookies';
my $key = 'two';
my $cookie1 = qq{\$Version="1"; one="1"};
my $cookie2 = qq{\$Version="1"; two="2"};
my $cookie3 = qq{\$Version="1"; three="3"};
my $value = qq{"2"};
my $str = GET_BODY("$location?test=$test&key=$key",
Cookie => $cookie1,
Cookie => $cookie2,
Cookie => $cookie3,
);
ok t_cmp($str, $value, $test);
}
{
my $test = 'cookies';
my $key = 'name';
my $cookie1 = qq{\$Version="1"; one="1"};
my $cookie2 = qq{\$Version="1"; two="2"};
my $cookie3 = qq{\$Version="1"; three="3"};
my $value = qq{one three two};
my $str = GET_BODY("$location?test=$test&key=$key",
Cookie => $cookie1,
Cookie => $cookie2,
Cookie => $cookie3,
);
ok t_cmp($str, $value, $test);
}
{
my $test = 'overload';
my $cookie = qq{\$Version="1"; one="1"};
my $value = qq{one="1"; Version=1};
my $str = GET_BODY("$location?test=$test", Cookie => $cookie);
ok t_cmp($str, $value, $test);
}
t/response/TestCGI/basic.pm view on Meta::CPAN
foreach my $method (@methods) {
can_ok($cgi, $method);
}
my $c = $cgi->cookie(-name => 'foo',
-value => 'bar',
-expires => '+3M',
-domain => '.capricorn.com',
-path => '/cgi-bin/database',
-secure => 1
);
isa_ok($c, 'CGI::Apache2::Wrapper::Cookie');
return Apache2::Const::OK;
}
1;
__END__
t/response/TestCGI/cookie.pm view on Meta::CPAN
package TestCGI::cookie;
use strict;
use warnings FATAL => 'all';
use CGI::Apache2::Wrapper ();
use CGI::Apache2::Wrapper::Cookie ();
use Apache2::Const -compile => qw(OK);
use Apache2::RequestRec;
use Apache2::RequestIO;
sub handler {
my $r = shift;
my $cgi = CGI::Apache2::Wrapper->new($r);
my $req = $cgi->req;
my %cookies = CGI::Apache2::Wrapper::Cookie->fetch($r);
my $test = $cgi->param('test');
my $key = $cgi->param('key');
if ($test eq 'cookies') {
if ($key eq 'first') {
my $value = $cgi->cookie('one');
$r->print($value);
}
t/response/TestCGI/cookie.pm view on Meta::CPAN
}
elsif ($test eq "bake2") {
$cookies{$key}->bake2($r);
}
$r->print($cookies{$key}->value);
}
else {
my @expires;
@expires = ("expires", $cgi->param('expires'))
if $cgi->param('expires');
my $cookie = CGI::Apache2::Wrapper::Cookie->new($r,
name => "foo",
value => $test,
domain => "example.com",
path => "/quux",
@expires);
if ($test eq "bake" or $test eq "") {
$cookie->bake($req);
}
$r->print($cookie->value);
}
t/response/TestCGI/cookie3.pm view on Meta::CPAN
{
# Try new with full information provided
my $c = $cgi->cookie(-name => 'foo',
-value => 'bar',
-expires => '+3M',
-domain => '.capricorn.com',
-path => '/cgi-bin/database',
-secure => 1
);
is(ref($c), 'CGI::Apache2::Wrapper::Cookie',
'new returns objects of correct type');
is($c->name , 'foo', 'name is correct');
is($c->value , 'bar', 'value is correct');
# like($c->expires,
# '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
is($c->domain , '.capricorn.com', 'domain is correct');
is($c->path , '/cgi-bin/database', 'path is correct');
ok($c->secure , 'secure attribute is set');
}
#------------------------------------------------------------------------
t/response/TestCGI/use_cgi_pm.pm view on Meta::CPAN
plan $r, tests => 2;
my $cgi = CGI::Apache2::Wrapper->new($r);
isa_ok($cgi, 'CGI');
my $c = $cgi->cookie(-name => 'foo',
-value => 'bar',
-expires => '+3M',
-domain => '.capricorn.com',
-path => '/cgi-bin/database',
-secure => 1
);
isa_ok($c, 'CGI::Cookie');
return Apache2::Const::OK;
}
1;
__END__
( run in 0.406 second using v1.01-cache-2.11-cpan-e9199f4ba4c )