=cut
###----------------------------------------------------------------###
-# Copyright 2006 - Paul Seamons #
+# Copyright 2003-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
use base qw(Exporter);
BEGIN {
- $VERSION = '2.00';
+ $VERSION = '2.37';
$PREFERRED_CGI_MODULE ||= 'CGI';
@EXPORT = ();
@EXPORT_OK = qw(get_form
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 $val = $form->{$key};
$key =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
$key =~ y/ /+/;
- foreach (ref($val) ? @$val : $val) {
+ foreach (ref($val) eq 'ARRAY' ? @$val : $val) {
my $_val = $_; # make a copy
$_val =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
$_val =~ y/ /+/;
my %hash = ();
foreach my $key ($obj->cookie) {
my @val = $obj->cookie($key);
- $hash{$key} = ($#val == -1) ? next : ($#val == 0) ? $val[0] : \@val;
+ $hash{$key} = ($#val == -1) ? "" : ($#val == 0) ? $val[0] : \@val;
}
return $self->{'cookies'} = \%hash;
}
my $self = shift || die 'Usage: $cgix_obj->apache_request';
$self->{'apache_request'} = shift if $#_ != -1;
- if (! $self->{'apache_request'}) {
- if ($self->is_mod_perl_1) {
- require Apache;
- $self->{'apache_request'} = Apache->request;
- } elsif ($self->is_mod_perl_2) {
- require Apache2::RequestRec;
- require Apache2::RequestUtil;
- $self->{'apache_request'} = Apache2::RequestUtil->request;
- }
- }
-
- return $self->{'apache_request'};
+ 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 {
- my $self = shift || die 'Usage: $cgix_obj->mod_perl_version';
-
- if (! defined $self->{'mod_perl_version'}) {
- return 0 if ! $ENV{'MOD_PERL'};
- # 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
- $self->{'mod_perl_version'} = ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x)
- ? $1 : '1.0_0';
- }
- return $self->{'mod_perl_version'};
-}
-
-sub is_mod_perl_1 { my $m = shift->mod_perl_version; return $m < 1.98 && $m > 0 }
-sub is_mod_perl_2 { my $m = shift->mod_perl_version; return $m >= 1.98 }
+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)
# print_content_type();
# print_content_type('text/plain);
sub print_content_type {
- my ($self, $type) = ($#_ >= 1) ? @_ : ref($_[0]) ? (shift, undef) : (undef, shift);
+ my ($self, $type, $charset) = (@_ && ref $_[0]) ? @_ : (undef, @_);
$self = __PACKAGE__->new if ! $self;
if ($type) {
} else {
$type = 'text/html';
}
+ $type .= "; charset=$charset" if $charset && $charset =~ m|^[\w\-\.\:\+]+$|;
if (my $r = $self->apache_request) {
return if $r->bytes_sent;
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;
+ die "Could not find file \"$time\" for time_calc. You should pass one of \"now\", time(), \"[+-] \\d+ [smhdwMy]\" or a filename." if $#stat == -1;
return $stat[9];
}
}
$r->send_http_header;
$r->print($mesg);
} else {
- # not sure of best way to send the message in MP2
+ $r->content_type('text/html');
+ $r->print($mesg);
+ $r->rflush;
}
} else {
print "Status: $code\r\n";
### get file info
my $stat;
- if ($js_file && $js_file =~ m|^(\w+(?:/+\w+)*\.js)$|i) {
+ if ($js_file && $js_file =~ m|^/*(\w+(?:/+\w+)*\.js)$|i) {
foreach my $path (@INC) {
my $_file = "$path/$1";
next if ! -f $_file;
header. Trying to print -E<gt>content_type is an error. For clarity,
the method -E<gt>print_content_type is available.
+ $cgix->print_content_type;
+
+ # OR
+ $cgix->print_content_type('text/html');
+
+ # OR
+ $cgix->print_content_type('text/html', 'utf-8');
+
=item C<-E<gt>set_cookie>
Arguments are the same as those to CGI->new->cookie({}).
or a shortened name which will be looked for in @INC. (ie /full/path/to/my.js
or CGI/Ex/validate.js or CGI::Ex::validate)
+ #!/usr/bin/perl
+ use CGI::Ex;
+ CGI::Ex->print_js($ENV{'PATH_INFO'});
+
=item C<-E<gt>swap_template>
This is intended as a simple yet strong subroutine to swap
See also L<CGI::Ex::Validate>.
-=head1 AUTHOR
-
-Paul Seamons
-
=head1 LICENSE
This module may be distributed under the same terms as Perl itself.
-=cut
+=head1 AUTHOR
-1;
+Paul Seamons <perl at seamons dot com>
+
+=cut