CGI-Utils
view release on metacpan or search on metacpan
lib/CGI/Utils.pm view on Meta::CPAN
mod_perl is supported if a value for apache_request is passed to
new(), or if the apache request object is available via
Apache->request, or if running under HTML::Mason. See the
documentation for the new() method for details.
If not running in a mod_perl or CGI environment, @ARGV will be
searched for key/value pairs in the format
key1=val1 key2=val2
If all command-line arguments are in this format, the key/value
pairs will be available as if they were passed via a CGI or
mod_perl interface.
=head1 METHODS
=cut
# TODO
# modify CGI::Utils::UploadFile to use hidden attributes instead of making up class names
# cache values like parsed cookies
# NPH stuff for getHeader()
use strict;
{ package CGI::Utils;
use vars qw($VERSION @ISA @EXPORT_OK @EXPORT %EXPORT_TAGS $AUTOLOAD);
use CGI::Utils::UploadFile;
BEGIN {
$VERSION = '0.12'; # update below in POD as well
local($SIG{__DIE__});
if (defined($ENV{MOD_PERL}) and $ENV{MOD_PERL} ne '') {
eval q{
use mod_perl;
$CGI::Utils::MP2 = $mod_perl::VERSION >= 1.99;
if (defined($CGI::Utils::MP2)) {
if ($CGI::Utils::MP2) {
require Apache2::Const;
require Apache2::RequestUtil;
}
else {
require Apache::Constants;
}
$CGI::Utils::Loaded_Apache_Constants = 1;
}
};
}
}
use constant MP2 => $CGI::Utils::MP2;
require Exporter;
@ISA = 'Exporter';
@EXPORT = ();
@EXPORT_OK = qw(urlEncode urlDecode urlEncodeVars urlDecodeVars getSelfRefHostUrl
getSelfRefUrl getSelfRefUrlWithQuery getSelfRefUrlDir addParamsToUrl
getParsedCookies escapeHtml escapeHtmlFormValue convertRelativeUrlWithParams
convertRelativeUrlWithArgs getSelfRefUri);
$EXPORT_TAGS{all_utils} = [ qw(urlEncode urlDecode urlEncodeVars urlDecodeVars
getSelfRefHostUrl
getSelfRefUrl getSelfRefUrlWithQuery getSelfRefUrlDir
addParamsToUrl getParsedCookies escapeHtml escapeHtmlFormValue
convertRelativeUrlWithParams convertRelativeUrlWithArgs
getSelfRefUri)
];
=pod
=head2 new(\%params)
Returns a new CGI::Utils object. Parameters are optional.
CGI::Utils supports mod_perl if the Apache request object is
passed as $params{apache_request}, or if it is available via
Apache->request (or Apache2::RequestUtil->request), or if running
under HTML::Mason.
You may also pass max_post_size in %params.
=cut
sub new {
my ($proto, $args) = @_;
$args = {} unless ref($args) eq 'HASH';
my $self = { _params => {}, _param_order => [], _upload_info => {},
_max_post_size => $$args{max_post_size},
_apache_request => $$args{apache_request},
_mason => $$args{mason},
};
bless $self, ref($proto) || $proto;
return $self;
}
# added for v0.07
sub _getApacheRequest {
my ($self) = @_;
my $r;
$r = $self->{_apache_request} if ref($self);
return $r if $r;
if ($ENV{MOD_PERL}) {
if ($self->_getMasonObject) {
# we're running under mason
return $self->_getApacheRequestFromMason;
} elsif (defined($mod_perl::VERSION)) {
if (MP2) {
$r = Apache2::RequestUtil->request;
}
else {
$r = Apache->request;
}
return $r if $r;
}
}
return;
}
sub _getModPerlVersion {
if (defined($mod_perl::VERSION)) {
if ($mod_perl::VERSION >= 1.99) {
return 2;
} else {
return 1;
lib/CGI/Utils.pm view on Meta::CPAN
my $host_url = $self->getSelfRefHostUrl;
my $uri = $self->getSelfRefUri;
$uri =~ s{^(.+?)\?.*$}{$1};
$uri =~ s{/[^/]+$}{};
if ($rel_url =~ m{^/}) {
$uri = $rel_url;
} else {
while ($rel_url =~ m{^\.\./}) {
$rel_url =~ s{^\.\./}{}; # pop dir off front
$uri =~ s{/[^/]+$}{}; # pop dir off end
}
$uri .= '/' . $rel_url;
}
return $self->addParamsToUrl($host_url . $uri, $args, $sep);
}
*convertRelativeUrlWithArgs = \&convertRelativeUrlWithParams;
*convert_relative_url_with_params = \&convertRelativeUrlWithParams;
*convert_relative_url_with_args = \&convertRelativeUrlWithParams;
=pod
=head2 addParamsToUrl($url, $param_hash, $sep)
Takes a url and reference to a hash of parameters to be added
onto the url as a query string and returns a url with those
parameters. It checks whether or not the url already contains a
query string and modifies it accordingly. If you want to add a
multivalued parameter, pass it as a reference to an array
containing all the values.
If the optional $sep parameter is passed, it is used as the
parameter separator instead of ';', unless the URL already
contains '&' chars, in which case it will use '&' for the
separator.
Aliases: add_params_to_url()
=cut
sub addParamsToUrl {
my ($self, $url, $param_hash, $sep) = @_;
return $url unless ref($param_hash) eq 'HASH' and %$param_hash;
$sep = ';' unless defined($sep) and $sep ne '';
if ($url =~ /^([^?]+)\?(.*)$/) {
my $query = $2;
# if query uses & for separator, then keep it consistent
if ($query =~ /\&/) {
$sep = '&';
}
$url .= $sep unless $url =~ /\?$/;
} else {
$url .= '?';
}
$url .= $self->urlEncodeVars($param_hash, $sep);
return $url;
}
*add_params_to_url = \&addParamsToUrl;
sub _getRawCookie {
my $self = shift;
if ($self->_isModPerl) {
my $r = $self->_getApacheRequest;
return $r ? $r->headers_in()->{Cookie} : ($ENV{HTTP_COOKIE} || $ENV{COOKIE} || '');
}
else {
return $ENV{HTTP_COOKIE} || $ENV{COOKIE} || '';
}
}
=pod
=head2 getParsedCookies()
Parses the cookies passed to the server. Returns a hash of
key/value pairs representing the cookie names and values.
Aliases: get_parsed_cookies
=cut
sub getParsedCookies {
my ($self) = @_;
my %cookies = map { (map { $self->urlDecode($_) } split(/=/, $_, 2)) }
split(/;\s*/, $self->_getRawCookie);
return \%cookies;
}
*get_parsed_cookies = \&getParsedCookies;
# added for v0.06
# for compatibility with CGI.pm
# may want to create an object here
sub cookie {
my ($self, @args) = @_;
my $map_list = [ 'name', [ 'value', 'values' ], 'path', 'expires', 'domain', 'secure' ];
my $params = $self->_parse_sub_params($map_list, \@args);
if (exists($$params{value})) {
return $params;
} else {
my $cookies = $self->getParsedCookies;
if ($cookies and %$cookies) {
return $$cookies{$$params{name}};
}
return '';
}
return $params;
}
# =pod
# =head2 parse({ max_post_size => $max_bytes })
# Parses the CGI parameters. GET and POST (both url-encoded and
# multipart/form-data encodings), including file uploads, are
# supported. If the request method is POST, you may pass a
# maximum number of bytes to accept via POST. This can be used to
# limit the size of file uploads, for example.
# =cut
sub parse {
my ($self, $args) = @_;
return 1 if $$self{_already_parsed};
$$self{_already_parsed} = 1;
$args = {} unless ref($args) eq 'HASH';
if ($self->_isModPerl) {
# If running under mod_perl, grab the GET or POST data
my $rv = $self->_modPerlParse($args);
return $rv if $rv;
} elsif (not $ENV{'GATEWAY_INTERFACE'}) {
# Not CGI, so must be commandline
if (scalar(@ARGV)) {
return $self->_cmdLineParse(\@ARGV);
}
}
# check for mod_perl - GATEWAY_INTERFACE =~ m{^CGI-Perl/}
# check for PerlEx - GATEWAY_INTERFACE =~ m{^CGI-PerlEx}
return $self->_cgiParse($args);
}
sub _cmdLineParse {
my $self = shift;
my $args = shift;
my %params;
foreach my $arg (@$args) {
if ($arg =~ /^([^=]+)=(.*)$/s) {
my $key = $1;
my $val = $2;
$params{$key} = $val;
}
else {
# bad param, drop them all
return;
}
lib/CGI/Utils.pm view on Meta::CPAN
if ($self->_isModPerl) {
return $self->_getHttpHeader('Content-Type');
} else {
return $ENV{CONTENT_TYPE};
}
}
*content_type = \&getContentType;
*get_content_type = \&getContentType;
=pod
=head2 getPathTranslated(), path_translated(), get_path_translated()
Returns the physical path information if provided in the CGI environment.
=cut
# added for 0.06
sub getPathTranslated {
my $self = shift;
return $self->_fromCgiOrModPerl('filename', 'PATH_TRANSLATED');
}
*path_translated = \&getPathTranslated;
*get_path_translated = \&getPathTranslated;
=pod
=head2 getQueryString(), query_string(), get_query_string()
Returns a query string created from the current parameters.
=cut
# create a query string from current CGI params
# added for 0.06
sub getQueryString {
my ($self) = @_;
my $fields = $self->getVars;
return $self->urlEncodeVars($fields);
}
*query_string = \&getQueryString;
*get_query_string = \&getQueryString;
=pod
=head2 getHeader(@args)
Generates HTTP headers. Standard arguments are content_type,
cookie, target, expires, and charset. These should be passed as
name/value pairs. If only one argument is passed, it is assumed
to be the 'content_type' argument. If no values are passed, the
content type is assumed to be 'text/html'. The charset defaults
to ISO-8859-1. A hash reference can also be passed. E.g.,
print $cgi_obj->getHeader({ content_type => 'text/html', expires => '+3d' });
The names 'content-type', and 'type' are aliases for
'content_type'. The arguments may also be passed CGI.pm style
with a '-' in front, e.g.
print $cgi_obj->getHeader( -content_type => 'text/html', -expires => '+3d' );
Cookies may be passed with the 'cookies' key either as a string,
a hash ref, or as a CGI::Cookies object, e.g.
my $cookie = { name => 'my_cookie', value => 'cookie_val' };
print $cgi_obj->getHeader(cookies => $cookie);
You may also pass an array of cookies, e.g.,
print $cgi_obj->getHeader(cookies => [ $cookie1, $cookie2 ]);
Aliases: header(), get_header
=cut
sub getHeader {
my ($self, @args) = @_;
my $arg_count = scalar(@args);
if ($arg_count == 0) {
return "Content-Type: text/html\r\n\r\n";
}
if ($arg_count == 1 and ref($args[0]) ne 'HASH') {
# content-type provided
return "Content-Type: $args[0]\r\n\r\n";
}
my $map_list = [ [ 'type', 'content-type', 'content_type' ],
'status',
[ 'cookie', 'cookies' ],
'target', 'expires', 'nph', 'charset', 'attachment',
'mod_perl',
];
my ($params, $extras) = $self->_parse_sub_params($map_list, \@args);
my $charset = $$params{charset} || 'ISO-8859-1';
my $content_type = $$params{type};
$content_type ||= 'text/html' unless defined($content_type);
$content_type .= "; charset=$charset"
if $content_type =~ /^text/ and $content_type !~ /\bcharset\b/;
# FIXME: handle NPH stuff
my $headers = [];
push @$headers, "Status: $$params{status}" if defined($$params{status});
push @$headers, "Window-Target: $$params{target}" if defined($$params{target});
my $cookies = $$params{cookie};
if (defined($cookies) and $cookies) {
my $cookie_array = ref($cookies) eq 'ARRAY' ? $cookies : [ $cookies ];
foreach my $cookie (@$cookie_array) {
# handle plain strings as well as CGI::Cookie objects and hashes
my $str = '';
if (UNIVERSAL::isa($cookie, 'CGI::Cookie')) {
$str = $cookie->as_string;
} elsif (ref($cookie) eq 'HASH') {
$str = $self->_createCookieStrFromHash($cookie);
} else {
$str = $cookie;
}
push @$headers, "Set-Cookie: $str" unless $str eq '';
}
}
if (defined($$params{expires})) {
my $expire = $self->_canonicalizeHttpDate($$params{expires});
push @$headers, "Expires: $expire";
}
if (defined($$params{expires}) or (defined($cookies) and $cookies)) {
push @$headers, "Date: " . $self->_canonicalizeHttpDate(0);
}
push @$headers, qq{Content-Disposition: attachment; filename="$$params{attachment}"}
if defined($$params{attachment});
push @$headers, "Content-Type: $content_type" if defined($content_type) and $content_type ne '';
if ($params->{mod_perl}) {
my $header_list = [];
foreach my $field (sort keys %$extras) {
my $val = $$extras{$field};
$field =~ s/\b(.)/\U$1/g;
$field = ucfirst($field);
push @$header_list, [ $field, $val ];
}
return $header_list;
}
foreach my $field (sort keys %$extras) {
my $val = $$extras{$field};
$field =~ s/\b(.)/\U$1/g;
$field = ucfirst($field);
push @$headers, "$field: $val";
}
# FIXME: make line endings work on windoze
return join("\r\n", @$headers) . "\r\n\r\n";
}
*header = \&getHeader;
*get_header = \&getHeader;
=pod
=head2 sendHeader(@args)
Like getHeader() above, except sends it. Under mod_perl, this
sends the header(s) via the Apache request object. In a CGI
environment, this prints the header(s) to STDOUT.
Aliases: send_header()
=cut
sub sendHeader {
my ($self, @args) = @_;
my $mod_perl = 0;
my $r;
if ($self->_isModPerl and $r = $self->_getApacheRequest) {
$mod_perl = 1;
}
lib/CGI/Utils.pm view on Meta::CPAN
}
*redirect = \&getRedirect;
=pod
=head2 sendRedirect($url)
Like getRedirect(), but in a CGI environment the output is sent
to STDOUT, and in a mod_perl environment, the appropriate
headers are set. The return value is 1 for a CGI environment
when successful, and Apache::Constants::REDIRECT in a mod_perl
environment, so you can do something like
return $utils->sendRedirect($url)
n a mod_perl handler.
Aliases: send_redirect()
=cut
sub send_redirect {
my ($self, @args) = @_;
my $map_list = [ [ 'location', 'uri', 'url' ],
'status',
[ 'cookie', 'cookies' ],
'target',
];
my ($params, $extras) = $self->_parse_sub_params($map_list, \@args);
$params->{status} = 302 unless $params->{status};
return $self->send_header({ type => '', %$params, %$extras });
}
*sendRedirect = \&send_redirect;
=pod
=head2 getLocalRedirect(), local_redirect(), get_local_redirect()
Like getRedirect(), except that the redirect URL is converted
from relative to absolute, including the host.
=cut
# Added for v0.07
sub getLocalRedirect {
my ($self, @args) = @_;
my $map_list = [ [ 'location', 'uri', 'url' ],
'status',
[ 'cookie', 'cookies' ],
'target',
];
my ($params, $extras) = $self->_parse_sub_params($map_list, \@args);
unless ($params->{location} =~ m{^https?://}) {
$params->{location} = $self->convertRelativeUrlWithParams($params->{location}, {});
}
return $self->getRedirect(%$params);
}
*local_redirect = \&getLocalRedirect;
*get_local_redirect = \&getLocalRedirect;
=pod
=head2 getCookieString(\%hash), get_cookie_string(\%hash);
Returns a string to pass as the value of a 'Set-Cookie' header.
=cut
sub getCookieString {
my ($self, $hash) = @_;
return $self->_createCookieStrFromHash($hash);
}
*get_cookie_string = \&getCookieString;
=pod
=head2 getSetCookieString(\%params), getSetCookieString([ \%params1, \%params2 ])
Returns a string to pass as the 'Set-Cookie' header(s), including
the line ending(s). Also accepts a simple hash with key/value pairs.
=cut
sub getSetCookieString {
my ($self, $cookies) = @_;
if (ref($cookies) eq 'HASH') {
my $array = [ map { { name => $_, value => $cookies->{$_} } } keys %$cookies ];
$cookies = $array;
}
my $cookie_array = ref($cookies) eq 'ARRAY' ? $cookies : [ $cookies ];
my $headers = [];
foreach my $cookie (@$cookie_array) {
# handle plain strings as well as CGI::Cookie objects and hashes
my $str = '';
if (UNIVERSAL::isa($cookie, 'CGI::Cookie')) {
$str = $cookie->as_string;
} elsif (ref($cookie) eq 'HASH') {
$str = $self->_createCookieStrFromHash($cookie);
} else {
$str = $cookie;
}
push @$headers, "Set-Cookie: $str" unless $str eq '';
}
# FIXME: make line endings work on windoze
return join("\r\n", @$headers) . "\r\n";
}
*get_set_cookie_string = \&getSetCookieString;
=pod
=head2 setCookie(\%params), set_cookie(\%params);
Sets the cookie generated by getCookieString. That is, in a
mod_perl environment, it adds an outgoing header to set the
cookie. In a CGI environment, it prints the value of
getSetCookieString to STDOUT (including the end-of-line
sequence).
=cut
sub setCookie {
my $self = shift;
my $params = shift;
my $str = $self->_createCookieStrFromHash($params);
my $r = $self->_getApacheRequest;
if ($r) {
$r->err_headers_out()->add('Set-Cookie' => $str);
}
else {
print STDOUT "Set-Cookie: $str\r\n";
}
}
*set_cookie = \&setCookie;
sub _createCookieStrFromHash {
my ($self, $hash) = @_;
my $pairs = [];
my $map_list = [ 'name', [ 'value', 'values', 'val' ],
'path', 'expires', 'domain', 'secure',
];
my $params = $self->_parse_sub_params($map_list, [ $hash ]);
my $value = $$params{value};
if (my $ref = ref($value)) {
if ($ref eq 'ARRAY') {
$value = join('&', map { $self->urlEncode($_) } @$value);
} elsif ($ref eq 'HASH') {
$value = join('&', map { $self->urlEncode($_) } %$value);
}
} else {
$value = $self->urlEncode($value);
}
push @$pairs, qq{$$params{name}=$value};
my $path = $$params{path} || '/';
push @$pairs, qq{path=$path};
push @$pairs, qq{domain=$$params{domain}} if $$params{domain};
if ($$params{expires}) {
my $expire = $self->_canonicalizeCookieDate($$params{expires});
push @$pairs, qq{expires=$expire};
}
push @$pairs, qq{secure} if $$params{secure};
return join('; ', @$pairs);
}
sub _canonicalizeCookieDate {
my ($self, $expire) = @_;
return $self->_canonicalizeDate('-', $expire);
}
sub _canonicalizeHttpDate {
my ($self, $expire) = @_;
return $self->_canonicalizeDate(' ', $expire);
my $time = $self->_get_expire_time_from_offset($expire);
return $time unless $time =~ /^\d+$/;
my $wdays = [ qw(Sun Mon Tue Wed Thu Fri Sat) ];
my $months = [ qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ];
my $sep = ' ';
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
$year += 1900 unless $year > 1000;
return sprintf "%s, %02d$sep%s$sep%04d %02d:%02d:%02d GMT",
$$wdays[$wday], $mday, $$months[$mon], $year, $hour, $min, $sec;
}
sub _canonicalizeDate {
my ($self, $sep, $expire) = @_;
my $time = $self->_get_expire_time_from_offset($expire);
return $time unless $time =~ /^\d+$/;
my $wdays = [ qw(Sun Mon Tue Wed Thu Fri Sat) ];
my $months = [ qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ];
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
$year += 1900 unless $year > 1000;
return sprintf "%s, %02d$sep%s$sep%04d %02d:%02d:%02d GMT",
$$wdays[$wday], $mday, $$months[$mon], $year, $hour, $min, $sec;
}
sub _get_expire_time_from_offset {
my ($self, $offset) = @_;
my $ret_offset = 0;
if (not $offset or lc($offset) eq 'now') {
$ret_offset = 0;
} elsif ($offset =~ /^\d+$/) {
return $offset;
} elsif ($offset =~ /^([-+]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
my $map = { 's' => 1,
'm' => 60,
'h' => 60 * 60,
'd' => 60 * 60 * 24,
'M' => 60 * 60 * 24 * 30,
'y' => 60 * 60 * 24 * 365,
};
$ret_offset = ($$map{$2} || 1) * $1;
} else {
$ret_offset = $offset;
}
return time() + $ret_offset;
}
( run in 2.263 seconds using v1.01-cache-2.11-cpan-6aa56a78535 )