=cut
###----------------------------------------------------------------###
-# Copyright 2006 - Paul Seamons #
+# Copyright 2003-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
$PREFERRED_CGI_REQUIRED
$AUTOLOAD
$DEBUG_LOCATION_BOUNCE
+ $CURRENT
@EXPORT @EXPORT_OK
);
use base qw(Exporter);
BEGIN {
- $VERSION = '2.02';
+ $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;
}
###----------------------------------------------------------------###
+### Get whether or not we are running as a PSGI app
+# my $app = CGI::Ex::App::PSGI->psgi_app('Foo::Bar::App');
+# $app->is_psgi; # is true
+sub is_psgi { shift->object->isa('CGI::PSGI') }
+
+### Allow for generating a PSGI response
+sub psgi_response {
+ my $self = shift;
+
+ $self->{psgi_responded} = 1;
+ $self->print_content_type;
+
+ if (my $location = $self->{psgi_location}) {
+ return [302, ['Content-Type' => 'text/html', Location => $location], ["Bounced to $location\n"]];
+ } else {
+ return [$self->{psgi_status} || 200, $self->{psgi_headers} || [], $self->{psgi_body} || ['']];
+ }
+}
+
+### Allow for sending a PSGI streaming/delayed response
+sub psgi_respond {
+ my $self = shift;
+ if ($self->{psgi_responder}) {
+ my $response = $self->psgi_response;
+ delete $response->[2];
+ $self->{psgi_writer} = $self->{psgi_responder}->($response);
+ delete $self->{psgi_responder};
+ }
+ $self->{psgi_writer};
+}
+
+###----------------------------------------------------------------###
+
### Allow for shared apache request object
# my $r = $cgix->apache_request
# $cgix->apache_request($r);
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';
+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 }
- 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';
+### Allow for a setter
+# $cgix->set_apache_request($r)
+sub set_apache_request { shift->apache_request(shift) }
+
+###----------------------------------------------------------------###
+
+### Portable method for printing the document content
+sub print_body {
+ my $self = shift || __PACKAGE__->new;
+
+ if ($self->is_psgi) {
+ if (my $writer = $self->psgi_respond) {
+ $writer->write($_) for (@_);
+ } else {
+ push @{$self->{psgi_body} ||= []}, $_ for (@_);
+ }
+ } else {
+ print <FH>;
}
- 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 }
+### Portable method for getting environment variables
+sub env {
+ my $self = shift || __PACKAGE__->new;
-### Allow for a setter
-# $cgix->set_apache_request($r)
-sub set_apache_request { shift->apache_request(shift) }
+ $self->is_psgi ? $self->object->env : \%ENV;
+}
###----------------------------------------------------------------###
# 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) {
+ if ($self->is_psgi) {
+ if (! $self->env->{'cgix.content_typed'}) {
+ push @{$self->{psgi_headers} ||= []}, ('Content-Type' => $type);
+ $self->env->{'cgix.content_typed'} = '';
+ }
+ $self->env->{'cgix.content_typed'} .= sprintf("%s, %d\n", (caller)[1,2]);
+ } elsif (my $r = $self->apache_request) {
return if $r->bytes_sent;
$r->content_type($type);
$r->send_http_header if $self->is_mod_perl_1;
sub content_typed {
my $self = shift || __PACKAGE__->new;
- if (my $r = $self->apache_request) {
+ if ($self->is_psgi) {
+ return $self->{psgi_responded};
+ } elsif (my $r = $self->apache_request) {
return $r->bytes_sent;
} else {
return $ENV{'CONTENT_TYPED'} ? 1 : undef;
if ($self->content_typed) {
if ($DEBUG_LOCATION_BOUNCE) {
- print "<a class=debug href=\"$loc\">Location: $loc</a><br />\n";
+ $self->print_body("<a class=debug href=\"$loc\">Location: $loc</a><br />\n");
} else {
- print "<meta http-equiv=\"refresh\" content=\"0;url=$loc\" />\n";
+ $self->print_body("<meta http-equiv=\"refresh\" content=\"0;url=$loc\" />\n");
}
+ } elsif ($self->is_psgi) {
+ $self->{psgi_location} = $loc;
+
} elsif (my $r = $self->apache_request) {
$r->status(302);
if ($self->is_mod_perl_1) {
my $cookie = "" . $obj->cookie(%$args);
if ($self->content_typed) {
- print "<meta http-equiv=\"Set-Cookie\" content=\"$cookie\" />\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);
- }
+ $self->print_body("<meta http-equiv=\"Set-Cookie\" content=\"$cookie\" />\n");
+ } elsif ($self->is_psgi) {
+ push @{$self->{psgi_headers} ||= []}, ('Set-Cookie' => $cookie);
+ } elsif (my $r = $self->apache_request) {
+ if ($self->is_mod_perl_1) {
+ $r->header_out("Set-cookie", $cookie);
} else {
- print "Set-Cookie: $cookie\r\n";
+ $r->headers_out->add("Set-Cookie", $cookie);
}
+ } else {
+ print "Set-Cookie: $cookie\r\n";
}
}
$time = scalar gmtime time_calc($time);
if ($self->content_typed) {
- print "<meta http-equiv=\"$key\" content=\"$time\" />\n";
+ $self->print_body("<meta http-equiv=\"$key\" content=\"$time\" />\n");
+ } elsif ($self->is_psgi) {
+ push @{$self->{psgi_headers} ||= []}, ($key => $time);
} elsif (my $r = $self->apache_request) {
if ($self->is_mod_perl_1) {
$r->header_out($key, $time);
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];
}
}
if ($self->content_typed) {
die "Cannot send a status ($code - $mesg) after content has been sent";
}
- if (my $r = $self->apache_request) {
+ if ($self->is_psgi) {
+ $self->{psgi_status} = $code;
+ $self->print_body($mesg);
+ } elsif (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 {
- # 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";
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_psgi) {
+ push @{$self->{psgi_headers} ||= []}, ($key => $val);
+ } elsif (my $r = $self->apache_request) {
if ($self->is_mod_perl_1) {
$r->header_out($key, $val);
} else {
### 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;
if (! $self->content_typed) {
$self->send_status(404, "JS File not found for print_js\n");
} else {
- print "<h1>JS File not found for print_js</h1>\n";
+ $self->print_body("<h1>JS File not found for print_js</h1>\n");
}
return;
}
$self->print_content_type('application/x-javascript');
}
- return if $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'HEAD';
+ return if $self->env->{'REQUEST_METHOD'} && $self->env->{'REQUEST_METHOD'} eq 'HEAD';
### send the contents
local *FH;
open(FH, "<$js_file") || die "Couldn't open file $js_file: $!";
local $/ = undef;
- print <FH>;
+ $self->print_body(<FH>);
close FH;
}
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