package CGI::Ex;
=head1 NAME
CGI::Ex - CGI utility suite - makes powerful application writing fun and easy
=cut
###----------------------------------------------------------------###
# Copyright 2007 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
### See perldoc at bottom
use strict;
use vars qw($VERSION
$PREFERRED_CGI_MODULE
$PREFERRED_CGI_REQUIRED
$AUTOLOAD
$DEBUG_LOCATION_BOUNCE
@EXPORT @EXPORT_OK
);
use base qw(Exporter);
BEGIN {
$VERSION = '2.12';
$PREFERRED_CGI_MODULE ||= 'CGI';
@EXPORT = ();
@EXPORT_OK = qw(get_form
get_cookies
print_content_type
content_type
content_typed
set_cookie
location_bounce
);
### cache mod_perl version (light if or if not mod_perl)
my $v = (! $ENV{'MOD_PERL'}) ? 0
# mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1
# if MOD_PERL is set - don't die if regex fails - just assume 1.0
: ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x) ? $1
: '1.0_0';
sub _mod_perl_version () { $v }
sub _is_mod_perl_1 () { $v < 1.98 && $v > 0 }
sub _is_mod_perl_2 () { $v >= 1.98 }
### cache apache request getter (light if or if not mod_perl)
my $sub;
if (_is_mod_perl_1) { # old mod_perl
require Apache;
$sub = sub { Apache->request };
} elsif (_is_mod_perl_2) {
if (eval { require Apache2::RequestRec }) { # debian style
require Apache2::RequestUtil;
$sub = sub { Apache2::RequestUtil->request };
} else { # fedora and mandrake style
require Apache::RequestUtil;
$sub = sub { Apache->request };
}
} else {
$sub = sub {};
}
sub apache_request_sub () { $sub }
}
###----------------------------------------------------------------###
# my $cgix = CGI::Ex->new;
sub new {
my $class = shift || die "Missing class name";
my $self = ref($_[0]) ? shift : {@_};
return bless $self, $class;
}
###----------------------------------------------------------------###
### allow for holding another classed CGI style object
# my $query = $cgix->object;
# $cgix->object(CGI->new);
sub object {
my $self = shift || die 'Usage: my $query = $cgix_obj->object';
$self->{'object'} = shift if $#_ != -1;
if (! defined $self->{'object'}) {
$PREFERRED_CGI_REQUIRED ||= do {
my $file = $self->{'cgi_module'} || $PREFERRED_CGI_MODULE;
$file .= ".pm";
$file =~ s|::|/|g;
eval { require $file };
die "Couldn't require $PREFERRED_CGI_MODULE: $@" if $@;
1; # return of do
};
$self->{'object'} = $PREFERRED_CGI_MODULE->new;
}
return $self->{'object'};
}
### allow for calling CGI MODULE methods
sub AUTOLOAD {
my $self = shift;
my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD";
return $self->object->$meth(@_);
}
sub DESTROY { }
###----------------------------------------------------------------###
### Form getter that will act like CGI->new->Vars only it will return arrayrefs
### for values that are arrays
# my $hash = $cgix->get_form;
# my $hash = $cgix->get_form(CGI->new);
# my $hash = get_form();
# my $hash = get_form(CGI->new);
sub get_form {
my $self = shift || __PACKAGE__->new;
if (! $self->isa(__PACKAGE__)) { # get_form(CGI->new) syntax
my $obj = $self;
$self = __PACKAGE__->new;
$self->object($obj);
}
return $self->{'form'} if $self->{'form'};
### get the info out of the object
my $obj = shift || $self->object;
my %hash = ();
foreach my $key ($obj->param) {
my @val = $obj->param($key);
$hash{$key} = ($#val <= 0) ? $val[0] : \@val;
}
return $self->{'form'} = \%hash;
}
### allow for a setter
### $cgix->set_form(\%form);
sub set_form {
my $self = shift || die 'Usage: $cgix_obj->set_form(\%form)';
return $self->{'form'} = shift || {};
}
### Combined get and set form
# my $hash = $cgix->form;
# $cgix->form(\%form);
sub form {
my $self = shift;
return $self->set_form(shift) if @_ == 1;
return $self->get_form;
}
### allow for creating a url encoded key value sequence
# my $str = $cgix->make_form(\%form);
# my $str = $cgix->make_form(\%form, \@keys_to_include);
sub make_form {
my $self = shift || die 'Usage: $cgix_obj->make_form(\%form)';
my $form = shift || $self->get_form;
my $keys = ref($_[0]) ? shift : [sort keys %$form];
my $str = '';
foreach (@$keys) {
my $key = $_; # make a copy
my $val = $form->{$key};
$key =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
$key =~ y/ /+/;
foreach (ref($val) ? @$val : $val) {
my $_val = $_; # make a copy
$_val =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
$_val =~ y/ /+/;
$str .= "$key=$_val&"; # intentionally not using join
}
}
chop $str;
return $str;
}
###----------------------------------------------------------------###
### like get_form - but a hashref of cookies
### cookies are parsed depending upon the functionality of ->cookie
# my $hash = $cgix->get_cookies;
# my $hash = $cgix->get_cookies(CGI->new);
# my $hash = get_cookies();
# my $hash = get_cookies(CGI->new);
sub get_cookies {
my $self = shift || __PACKAGE__->new;
if (! $self->isa(__PACKAGE__)) { # get_cookies(CGI->new) syntax
my $obj = $self;
$self = __PACKAGE__->new;
$self->object($obj);
}
return $self->{'cookies'} if $self->{'cookies'};
my $obj = shift || $self->object;
my %hash = ();
foreach my $key ($obj->cookie) {
my @val = $obj->cookie($key);
$hash{$key} = ($#val == -1) ? next : ($#val == 0) ? $val[0] : \@val;
}
return $self->{'cookies'} = \%hash;
}
### Allow for a setter
### $cgix->set_cookies(\%cookies);
sub set_cookies {
my $self = shift || die 'Usage: $cgix_obj->set_cookies(\%cookies)';
return $self->{'cookies'} = shift || {};
}
### Combined get and set cookies
# my $hash = $cgix->cookies;
# $cgix->cookies(\%cookies);
sub cookies {
my $self = shift;
return $self->set_cookies(shift) if @_ == 1;
return $self->get_cookies;
}
###----------------------------------------------------------------###
### Allow for shared apache request object
# my $r = $cgix->apache_request
# $cgix->apache_request($r);
sub apache_request {
my $self = shift || die 'Usage: $cgix_obj->apache_request';
$self->{'apache_request'} = shift if $#_ != -1;
return $self->{'apache_request'} ||= apache_request_sub()->();
}
### Get the version of mod_perl running (0 if not mod_perl)
# my $version = $cgix->mod_perl_version;
sub mod_perl_version { _mod_perl_version }
sub is_mod_perl_1 { _is_mod_perl_1 }
sub is_mod_perl_2 { _is_mod_perl_2 }
### Allow for a setter
# $cgix->set_apache_request($r)
sub set_apache_request { shift->apache_request(shift) }
###----------------------------------------------------------------###
### same signature as print_content_type
sub content_type { &print_content_type }
### will send the Content-type header
# $cgix->print_content_type;
# $cgix->print_content_type('text/plain');
# print_content_type();
# print_content_type('text/plain);
sub print_content_type {
my ($self, $type) = ($#_ >= 1) ? @_ : ref($_[0]) ? (shift, undef) : (undef, shift);
$self = __PACKAGE__->new if ! $self;
if ($type) {
die "Invalid type: $type" if $type !~ m|^[\w\-\.]+/[\w\-\.\+]+$|; # image/vid.x-foo
} else {
$type = 'text/html';
}
if (my $r = $self->apache_request) {
return if $r->bytes_sent;
$r->content_type($type);
$r->send_http_header if $self->is_mod_perl_1;
} else {
if (! $ENV{'CONTENT_TYPED'}) {
print "Content-Type: $type\r\n\r\n";
$ENV{'CONTENT_TYPED'} = '';
}
$ENV{'CONTENT_TYPED'} .= sprintf("%s, %d\n", (caller)[1,2]);
}
}
### Boolean check if content has been typed
# $cgix->content_typed;
# content_typed();
sub content_typed {
my $self = shift || __PACKAGE__->new;
if (my $r = $self->apache_request) {
return $r->bytes_sent;
} else {
return $ENV{'CONTENT_TYPED'} ? 1 : undef;
}
}
###----------------------------------------------------------------###
### location bounce nicely - even if we have already sent content
### may be called as function or a method
# $cgix->location_bounce($url);
# location_bounce($url);
sub location_bounce {
my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift);
$self = __PACKAGE__->new if ! $self;
if ($self->content_typed) {
if ($DEBUG_LOCATION_BOUNCE) {
print "Location: $loc
\n";
} else {
print "\n";
}
} elsif (my $r = $self->apache_request) {
$r->status(302);
if ($self->is_mod_perl_1) {
$r->header_out("Location", $loc);
$r->content_type('text/html');
$r->send_http_header;
$r->print("Bounced to $loc\n");
} else {
$r->headers_out->add("Location", $loc);
$r->content_type('text/html');
$r->rflush;
}
} else {
print "Location: $loc\r\n",
"Status: 302 Bounce\r\n",
"Content-Type: text/html\r\n\r\n",
"Bounced to $loc\r\n";
}
}
### set a cookie nicely - even if we have already sent content
### may be called as function or a method - fancy algo to allow for first argument of args hash
# $cgix->set_cookie({name => $name, ...});
# $cgix->set_cookie( name => $name, ... );
# set_cookie({name => $name, ...});
# set_cookie( name => $name, ... );
sub set_cookie {
my $self = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
my $args = ref($_[0]) ? shift : {@_};
foreach (keys %$args) {
next if /^-/;
$args->{"-$_"} = delete $args->{$_};
}
### default path to / and allow for 1hour instead of 1h
$args->{-path} ||= '/';
$args->{-expires} = time_calc($args->{-expires}) if $args->{-expires};
my $obj = $self->object;
my $cookie = "" . $obj->cookie(%$args);
if ($self->content_typed) {
print "\n";
} else {
if (my $r = $self->apache_request) {
if ($self->is_mod_perl_1) {
$r->header_out("Set-cookie", $cookie);
} else {
$r->headers_out->add("Set-Cookie", $cookie);
}
} else {
print "Set-Cookie: $cookie\r\n";
}
}
}
### print the last modified time
### takes a time or filename and an optional keyname
# $cgix->last_modified; # now
# $cgix->last_modified((stat $file)[9]); # file's time
# $cgix->last_modified(time, 'Expires'); # different header
sub last_modified {
my $self = shift || die 'Usage: $cgix_obj->last_modified($time)'; # may be called as function or method
my $time = shift || time;
my $key = shift || 'Last-Modified';
### get a time string - looks like:
### Mon Dec 9 18:03:21 2002
### valid RFC (although not prefered)
$time = scalar gmtime time_calc($time);
if ($self->content_typed) {
print "\n";
} elsif (my $r = $self->apache_request) {
if ($self->is_mod_perl_1) {
$r->header_out($key, $time);
} else {
$r->headers_out->add($key, $time);
}
} else {
print "$key: $time\r\n";
}
}
### add expires header
sub expires {
my $self = ref($_[0]) ? shift : __PACKAGE__->new; # may be called as a function or method
my $time = shift || time;
return $self->last_modified($time, 'Expires');
}
### similar to expires_calc from CGI::Util
### allows for lenient calling, hour instead of just h, etc
### takes time or 0 or now or filename or types of -23minutes
sub time_calc {
my $time = shift; # may only be called as a function
if (! $time || lc($time) eq 'now') {
return time;
} elsif ($time =~ m/^\d+$/) {
return $time;
} elsif ($time =~ m/^([+-]?)\s*(\d+|\d*\.\d+)\s*([a-z])[a-z]*$/i) {
my $m = {
's' => 1,
'm' => 60,
'h' => 60 * 60,
'd' => 60 * 60 * 24,
'w' => 60 * 60 * 24 * 7,
'M' => 60 * 60 * 24 * 30,
'y' => 60 * 60 * 24 * 365,
};
return time + ($m->{lc($3)} || 1) * "$1$2";
} else {
my @stat = stat $time;
die "Could not find file \"$time\" for time_calc" if $#stat == -1;
return $stat[9];
}
}
### allow for generic status send
sub send_status {
my $self = shift || die 'Usage: $cgix_obj->send_status(302 => "Bounced")';
my $code = shift || die "Missing status";
my $mesg = shift;
if (! defined $mesg) {
$mesg = "HTTP Status of $code received\n";
}
if ($self->content_typed) {
die "Cannot send a status ($code - $mesg) after content has been sent";
}
if (my $r = $self->apache_request) {
$r->status($code);
if ($self->is_mod_perl_1) {
$r->content_type('text/html');
$r->send_http_header;
$r->print($mesg);
} else {
$r->content_type('text/html');
$r->print($mesg);
$r->rflush;
}
} else {
print "Status: $code\r\n";
$self->print_content_type;
print $mesg;
}
}
### allow for sending a simple header
sub send_header {
my $self = shift || die 'Usage: $cgix_obj->send_header';
my $key = shift;
my $val = shift;
if ($self->content_typed) {
die "Cannot send a header ($key - $val) after content has been sent";
}
if (my $r = $self->apache_request) {
if ($self->is_mod_perl_1) {
$r->header_out($key, $val);
} else {
$r->headers_out->add($key, $val);
}
} else {
print "$key: $val\r\n";
}
}
###----------------------------------------------------------------###
### allow for printing out a static javascript file
### for example $self->print_js("CGI::Ex::validate.js");
sub print_js {
my $self = shift || die 'Usage: $cgix_obj->print_js($js_file)';
my $js_file = shift || '';
$self = $self->new if ! ref $self;
### fix up the file - force .js on the end
$js_file .= '.js' if $js_file && $js_file !~ /\.js$/i;
$js_file =~ s|::|/|g;
### get file info
my $stat;
if ($js_file && $js_file =~ m|^(\w+(?:/+\w+)*\.js)$|i) {
foreach my $path (@INC) {
my $_file = "$path/$1";
next if ! -f $_file;
$js_file = $_file;
$stat = [stat _];
last;
}
}
### no file = 404
if (! $stat) {
if (! $self->content_typed) {
$self->send_status(404, "JS File not found for print_js\n");
} else {
print "