CGI-Apache2-Wrapper
view release on metacpan or search on metacpan
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
package CGI::Apache2::Wrapper;
use strict;
use warnings;
use File::Basename;
use APR::Const -compile => qw(URI_UNP_OMITSITEPART
URI_UNP_OMITPATHINFO
URI_UNP_OMITQUERY);
our $VERSION = '0.215';
our $MOD_PERL;
sub new {
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;
return CGI->new($r);
}
if (exists $ENV{MOD_PERL}) {
if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
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};
}
my $self = {};
bless $self, ref $class || $class;
$self->r($r) unless $self->r;
$self->c($r->connection) unless $self->c;
$self->req(Apache2::Request->new($self->r)) unless $self->req;
return $self;
}
sub r {
my $self = shift;
my $r = $self->{'.r'};
$self->{'.r'} = shift if @_;
return $r;
}
sub c {
my $self = shift;
my $c = $self->{'.c'};
$self->{'.c'} = shift if @_;
return $c;
}
sub req {
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;
my $uploads = {};
foreach my $u (@u) {
next unless defined $u;
my $tempname = $u->tempname();
open(my $fh, '<', $tempname) or next;
my $info = { %{$u->info()},
name => $name,
filename => $u->filename(),
size => $u->size(),
type => $u->type(),
};
$uploads->{"$fh"} = {filehandle => $fh,
tempname => $tempname,
info => $info,
};
push @$tmpfhs, $fh;
}
$self->{'.uploads'} = $uploads;
$self->{'.tmpfhs'}->{$name} = $tmpfhs;
return $tmpfhs;
}
# Apache2::Request
sub param {
return shift->req->param(@_);
}
# Apache2::Connection
sub remote_addr {
return shift->c->remote_ip;
}
sub remote_host {
return shift->c->remote_host;
}
# Apache2::Access
sub auth_type {
return shift->r->auth_type;
}
sub remote_ident {
return shift->r->get_remote_logname;
}
# Apache2::RequestUtil
sub remote_user {
return shift->r->user;
}
sub user_name {
my $self = shift;
return ($self->remote_ident || $self->remote_user);
}
sub server_name {
return shift->r->get_server_name;
}
sub server_port {
return shift->r->get_server_port;
}
# Apache2::RequestRec
sub header {
my $self = shift;
my $header_extra;
if (@_) {
if (scalar @_ == 1) {
$header_extra = shift;
}
else {
my %args = @_;
$header_extra = \%args;
}
}
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 '';
}
sub query_string {
return shift->r->args;
}
sub server_protocol {
return shift->r->protocol;
}
sub request_method {
return shift->r->method;
}
sub content_type {
return shift->r->content_type;
}
sub path_info {
return shift->r->path_info;
}
sub redirect {
return shift->r->headers_out->set(Location => @_);
}
sub status {
return shift->r->status(@_);
}
# Apache2::URI
sub url {
my ($self, %args) = @_;
my $r = $self->r;
my $url = $r->construct_url;
if (my $args = $r->args) {
$url .= '?' . $args;
}
my $path_info = $r->path_info;
if ($path_info eq '/') {
$path_info = undef;
}
if ($path_info) {
$path_info = quotemeta($path_info);
}
my $parsed = APR::URI->parse($r->pool, $url);
my %opts;
foreach my $key(keys %args) {
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
}
last SWITCH;
};
($opts{base}) and do {
$rv = $parsed->unparse(APR::Const::URI_UNP_OMITPATHINFO);
last SWITCH;
};
($opts{absolute}) and do {
$rv = $parsed->unparse(APR::Const::URI_UNP_OMITSITEPART |
APR::Const::URI_UNP_OMITQUERY);
if ($path_info) {
$rv =~ s/$path_info//;
}
last SWITCH;
};
($opts{path}) and do {
$rv = $parsed->unparse(APR::Const::URI_UNP_OMITQUERY);
last SWITCH;
};
($opts{relative}) and do {
if (my $file = $r->filename) {
$rv = basename($file);
}
else {
$rv = $parsed->unparse(APR::Const::URI_UNP_OMITQUERY);
if ($path_info) {
$rv =~ s/$path_info//;
}
$rv =~ s{^/}{};
}
last SWITCH;
};
$opts{query} and do {
last SWITCH;
};
die qq{Unknown option passed to url};
}
unless ($rv) {
$rv = $parsed->unparse(APR::Const::URI_UNP_OMITQUERY);
if ($path_info) {
$rv =~ s/$path_info//;
}
}
if ($opts{query}) {
$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 = @_;
}
}
if (%args and not $name) {
($name, $value) = ( ($args{'-name'} || $args{name} ),
($args{'-value'} || $args{value} ));
}
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');
return wantarray ? @$tmpfhs : $tmpfhs->[0];
}
sub tmpFileName {
my ($self, $fh) = @_;
return unless (defined $fh and ref($fh) eq 'GLOB');
my $uploads = $self->{'.uploads'};
return unless (defined $uploads and ref($uploads) eq 'HASH');
return (defined $uploads->{"$fh"} and
defined $uploads->{"$fh"}->{tempname} ) ?
$uploads->{"$fh"}->{tempname} : undef;
}
sub uploadInfo {
my ($self, $fh) = @_;
return unless (defined $fh and ref($fh) eq 'GLOB');
my $uploads = $self->{'.uploads'};
return unless (defined $uploads and ref($uploads) eq 'HASH');
return (defined $uploads->{"$fh"} and
defined $uploads->{"$fh"}->{info} ) ?
$uploads->{"$fh"}->{info} : undef;
}
1;
__END__
=head1 NAME
CGI::Apache2::Wrapper - CGI.pm-compatible methods via mod_perl
=head1 SYNOPSIS
sub handler {
my $r = shift;
my $cgi = CGI::Apache2::Wrapper->new($r);
my $foo = $cgi->param("foo");
my $header = {'Content-Type' => 'text/plain; charset=utf-8',
'X-err_header_out' => 'err_headers_out',
};
$cgi->header($header);
$r->print("You passed in $foo\n");
return Apache2::Const::OK;
}
=head1 DESCRIPTION
Certain modules, such as L<CGI::Ajax> and
L<JavaScript::Autocomplete::Backend>,
require a minimal L<CGI.pm>-compatible module to provide certain methods,
lib/CGI/Apache2/Wrapper.pm view on Meta::CPAN
<Location /TestCGI>
SetHandler modperl
PerlResponseHandler My::Handler
</Location>
on port 8529 and the request
I<http://localhost:8529/TestCGI/extra/path/info?opening=hello> is made.
The following options for %opts are recognized:
=over
=item * no options
Called without any arguments, this returns the full
form of the URL, including host name and port number:
I<http://localhost:8529/TestCGI>
=item * -absolute =E<gt> 1
This produces an absolute url: I</TestCGI>
=item * -relative =E<gt> 1
This produces an relative url: I<TestCGI>
=item * -full =E<gt> 1
This produces a full url: I<http://localhost:8529/TestCGI>
=item * -path =E<gt> 1 (or -path_info =E<gt> 1)
This appends the additional path information to the url:
I<http://localhost:8529/TestCGI/extra/path/info>
=item * -query =E<gt> 1 (or -query_string =E<gt> 1)
This appends the query string to the url:
I<http://localhost:8529/TestCGI?opening=hello;closing=goodbye>
=item * -base =E<gt> 1
This generates just the protocol and net location:
I<http://localhost:8529>
=back
Specifying the options I<-path =E<gt> 1> and I<-query =E<gt> 1>
will lead to the complete url:
I<http://localhost:8529/TestCGI/extra/path/info?opening=hello;closing=goodbye>.
=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>
This is the value associated with the cookie (required)
=item * I<-expires>
This accepts any of the relative or absolute date formats
recognized by CGI.pm, for example "+3M" for three months in the future.
See L<CGI.pm> for details.
=item * I<-domain>
This points to a domain name or to a fully qualified
host name. If not specified, the cookie will be returned only
to the Web server that created it.
=item * I<-path>
This points to a partial URL on the current server.
The cookie will be returned to all URLs beginning with
the specified path. If not specified, it defaults to '/',
which returns the cookie to all pages at your site.
=item * I<-secure>
If set to a true value, this instructs the
browser to return the cookie only when a cryptographic protocol is in use.
=back
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:
my @fhs = $cgi->upload('filename');
will return an array of filehandles. There are two
helper methods available for uploads:
=over
=item * my $tmpfile = $cgi-E<gt>tmpFileName($fh);
This returns the name of the temporary file associated with
the I<$fh> fielhandle returned from I<upload>.
=item * my $info = $cgi-E<gt>uploadInfo($fh);
This returns a hash reference containing some information about
the uploaded file associated with the I<$fh> filehandle
returned from I<upload>. The keys of this hash typically include:
=over
=item * Content-Type
The content type, such as I<text/plain>, associated with this upload.
=item * Content-Disposition
This typically is a string such as
I<form-data; name="HTTPUPLOAD"; filename="data.txt">.
=item * size
This is the size of the uploaded file.
=item * name
This is the name of the HTML form element which generated the upload.
=item * filename
The (client-side) filename as submitted in the HTML form.
Note that some agents will submit the file's full pathname,
while others may submit just the basename.
=item * type
This is the MIME type of the upload.
=back
( run in 1.849 second using v1.01-cache-2.11-cpan-39bf76dae61 )