X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FCGI%2FEx.pm;h=772dcbd12306d69fb83f6cf66b91ec6590bdf6c5;hb=8a1796477c5a835d8c124cfa8504909dc786d93b;hp=cbc5a349b83305bd668424fc2950a572e4e5f611;hpb=85070b46d0a93ddbeef07341421adb8389a55418;p=chaz%2Fp5-CGI-Ex
diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm
index cbc5a34..772dcbd 100644
--- a/lib/CGI/Ex.pm
+++ b/lib/CGI/Ex.pm
@@ -1,9 +1,13 @@
package CGI::Ex;
-### CGI Extended
+=head1 NAME
+
+CGI::Ex - CGI utility suite - makes powerful application writing fun and easy
+
+=cut
###----------------------------------------------------------------###
-# Copyright 2003 - Paul Seamons #
+# Copyright 2007 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
@@ -11,70 +15,97 @@ package CGI::Ex;
use strict;
use vars qw($VERSION
- $PREFERRED_FILL_MODULE
$PREFERRED_CGI_MODULE
$PREFERRED_CGI_REQUIRED
- $TEMPLATE_OPEN
- $TEMPLATE_CLOSE
$AUTOLOAD
$DEBUG_LOCATION_BOUNCE
@EXPORT @EXPORT_OK
);
use base qw(Exporter);
-$VERSION = '1.14';
-$PREFERRED_FILL_MODULE ||= '';
-$PREFERRED_CGI_MODULE ||= 'CGI';
-$TEMPLATE_OPEN ||= qr/\[%\s*/;
-$TEMPLATE_CLOSE ||= qr/\s*%\]/;
-@EXPORT = ();
-@EXPORT_OK = qw(get_form
- get_cookies
- print_content_type
- content_type
- content_typed
- set_cookie
- );
+BEGIN {
+ $VERSION = '2.09';
+ $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;
+ 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' if ! ref $self;
- return $self->{'object'} = shift if $#_ != -1;
- return $self->{'object'} ||= do {
- $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 inner do
- };
- $PREFERRED_CGI_MODULE->new; # return of the do
- };
+ 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 their methods
+### allow for calling CGI MODULE methods
sub AUTOLOAD {
- my $self = shift;
- my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD";
- return wantarray # does wantarray propogate up ?
- ? ($self->object->$meth(@_))
- : $self->object->$meth(@_);
+ my $self = shift;
+ my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD";
+ return $self->object->$meth(@_);
}
-sub DESTROY {}
+sub DESTROY { }
###----------------------------------------------------------------###
@@ -85,69 +116,62 @@ sub DESTROY {}
# my $hash = get_form();
# my $hash = get_form(CGI->new);
sub get_form {
- my $self = shift;
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->get_form' if ! ref $self;
- if (! UNIVERSAL::isa($self, __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 == -1) ? die : ($#val == 0) ? $val[0] : \@val;
- }
- return $self->{'form'} = \%hash;
+ 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)' if ! ref $self;
- $self->{'form'} = shift || {};
+ 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;
- die (defined wantarray
- ? 'Usage: my $form = $cgix_obj->form' : 'Usage: $cgix_obj->form(\%form)')
- if ! UNIVERSAL::isa($self, __PACKAGE__);
- return $self->set_form(shift) if $#_ != -1;
- return $self->get_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)' if ! ref $self;
- 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
+ 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;
+ chop $str;
+ return $str;
}
###----------------------------------------------------------------###
@@ -159,44 +183,37 @@ sub make_form {
# my $hash = get_cookies();
# my $hash = get_cookies(CGI->new);
sub get_cookies {
- my $self = shift;
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->get_cookies' if ! ref $self;
- if (! UNIVERSAL::isa($self, __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;
- use CGI::Ex::Dump qw(debug);
- 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;
+ 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)' if ! ref $self;
- $self->{'cookies'} = shift || {};
+ 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;
- die (defined wantarray
- ? 'Usage: my $hash = $cgix_obj->cookies' : 'Usage: $cgix_obj->cookies(\%cookies)')
- if ! UNIVERSAL::isa($self, __PACKAGE__);
- return $self->set_cookies(shift) if $#_ != -1;
- return $self->get_cookies;
+ my $self = shift;
+ return $self->set_cookies(shift) if @_ == 1;
+ return $self->get_cookies;
}
###----------------------------------------------------------------###
@@ -205,33 +222,17 @@ sub cookies {
# my $r = $cgix->apache_request
# $cgix->apache_request($r);
sub apache_request {
- my $self = shift;
- die 'Usage: $cgix_obj->apache_request' if ! ref $self;
- $self->{'apache_request'} = shift if $#_ != -1;
- if (! defined $self->{'apache_request'}) {
- return if ! $self->mod_perl_version;
- $self->{'apache_request'} = Apache->request;
- }
- return $self->{'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 {
- my $self = shift;
- die 'Usage: $cgix_obj->mod_perl_version' if ! ref $self;
- if (! defined $self->{'mod_perl_version'}) {
- return 0 if ! $ENV{'MOD_PERL'};
- # mod_perl/1.27 or mod_perl/1.99_16
- # 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_]+)$|)
- ? $1 : '1.0_0';
- }
- return $self->{'mod_perl_version'};
-}
-
-sub is_mod_perl_1 { shift->mod_perl_version < 1.98 }
-sub is_mod_perl_2 { shift->mod_perl_version >= 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)
@@ -240,9 +241,7 @@ sub set_apache_request { shift->apache_request(shift) }
###----------------------------------------------------------------###
### same signature as print_content_type
-sub content_type {
- &print_content_type;
-}
+sub content_type { &print_content_type }
### will send the Content-type header
# $cgix->print_content_type;
@@ -250,41 +249,39 @@ sub content_type {
# 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;
- die 'Usage: $cgix_obj->print_content_type' if ! ref $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'} = '';
+ 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]);
}
- $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;
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->content_typed' if ! ref $self;
-
- if (my $r = $self->apache_request) {
- return $r->bytes_sent;
- } else {
- return ($ENV{'CONTENT_TYPED'}) ? 1 : undef;
- }
+ my $self = shift || __PACKAGE__->new;
+
+ if (my $r = $self->apache_request) {
+ return $r->bytes_sent;
+ } else {
+ return $ENV{'CONTENT_TYPED'} ? 1 : undef;
+ }
}
###----------------------------------------------------------------###
@@ -294,36 +291,35 @@ sub content_typed {
# $cgix->location_bounce($url);
# location_bounce($url);
sub location_bounce {
- my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift);
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->location_bounce($url)' if ! ref $self;
+ 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;
+ }
- if ($self->content_typed) {
- if ($DEBUG_LOCATION_BOUNCE) {
- print "Location: $loc
\n";
- } else {
- print "\n";
- }
- } else {
- if (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 {
- my $t = $r->headers_out;
- $t->add("Location", $loc);
- $r->headers_out($t);
- }
} else {
- print "Location: $loc\r\n",
- "Status: 302 Bounce\r\n",
- "Content-Type: text/html\r\n\r\n",
- "Bounced to $loc\r\n";
+ 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
@@ -333,35 +329,34 @@ sub location_bounce {
# 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 {
- my $t = $r->headers_out;
- $t->add("Set-Cookie", $cookie);
- $r->headers_out($t);
- }
+ 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 {
- print "Set-Cookie: $cookie\r\n"
+ 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
@@ -369,119 +364,110 @@ sub set_cookie {
# $cgix->last_modified; # now
# $cgix->last_modified((stat $file)[9]); # file's time
# $cgix->last_modified(time, 'Expires'); # different header
-# last_modified(); # now
-# last_modified((stat $file)[9]); # file's time
-# last_modified(time, 'Expires'); # different header
sub last_modified {
- my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as function or method
- $self = $self->new if ! ref $self;
- 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";
- } else {
- if (my $r = $self->apache_request) {
- if ($self->is_mod_perl_1) {
- $r->header_out($key, $time);
- } else {
- my $t = $r->headers_out;
- $t->add($key, $time);
- $r->headers_out($t);
- }
+ 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"
+ print "$key: $time\r\n";
}
- }
-
}
### add expires header
sub expires {
- my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as a function or method
- my $time = shift || time;
- return $self->last_modified($time, '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];
- }
+ 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 = ref($_[0]) ? shift : __PACKAGE__; # may be called as function or method
- 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);
+ 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 {
- # not sure of best way to send the message in MP2
+ print "Status: $code\r\n";
+ $self->print_content_type;
+ print $mesg;
}
- } else {
- print "Status: $code\r\n";
- $self->print_content_type;
- print $mesg;
- }
}
### allow for sending a simple header
sub send_header {
- my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as function or method
- my $key = shift;
- my $value = shift;
- if ($self->content_typed) {
- die "Cannot send a header ($key - $value) after content has been sent";
- }
- if (my $r = $self->apache_request) {
- if ($self->is_mod_perl_1) {
- $r->header_out($key, $value);
+ 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 {
- my $t = $r->headers_out;
- $t->add($key, $value);
- $r->headers_out($t);
+ print "$key: $val\r\n";
}
- } else {
- print "$key: $value\r\n";
- }
}
###----------------------------------------------------------------###
@@ -489,59 +475,51 @@ sub send_header {
### allow for printing out a static javascript file
### for example $self->print_js("CGI::Ex::validate.js");
sub print_js {
- my ($self, $js_file) = ($#_ == 1) ? (@_) : (__PACKAGE__, 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) {
- # do nothing - give the 404
- } elsif ($js_file !~ m|^\.{0,2}/|) {
- foreach my $path (@INC) {
- my $_file = "$path/$js_file";
- next if ! -f $_file;
- $js_file = $_file;
- $stat = [stat _];
- last;
+ 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;
+ }
}
- } else {
- if (-f $js_file) {
- $stat = [stat _];
+
+ ### no file = 404
+ if (! $stat) {
+ if (! $self->content_typed) {
+ $self->send_status(404, "JS File not found for print_js\n");
+ } else {
+ print "