X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-CGI-Ex;a=blobdiff_plain;f=lib%2FCGI%2FEx.pm;h=bc44ab4ca563d088bcfae39e092417a7a4d53b1b;hp=03d0f02e0975245fb481c7545eb7746c52dfb33a;hb=ed00221d27dfab1e82ec2ea040ab4c399a91c545;hpb=4eee158dce82376f2f37de29d91c53f60a24aebe

diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm
index 03d0f02..bc44ab4 100644
--- a/lib/CGI/Ex.pm
+++ b/lib/CGI/Ex.pm
@@ -7,7 +7,7 @@ CGI::Ex - CGI utility suite - makes powerful application writing fun and easy
 =cut
 
 ###----------------------------------------------------------------###
-#  Copyright 2006 - Paul Seamons                                     #
+#  Copyright 2007 - Paul Seamons                                     #
 #  Distributed under the Perl Artistic License without warranty      #
 ###----------------------------------------------------------------###
 
@@ -24,7 +24,7 @@ use vars qw($VERSION
 use base qw(Exporter);
 
 BEGIN {
-    $VERSION               = '2.00';
+    $VERSION               = '2.24';
     $PREFERRED_CGI_MODULE  ||= 'CGI';
     @EXPORT = ();
     @EXPORT_OK = qw(get_form
@@ -35,6 +35,34 @@ BEGIN {
                     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 }
 }
 
 ###----------------------------------------------------------------###
@@ -197,37 +225,14 @@ sub apache_request {
     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)
@@ -244,7 +249,7 @@ sub content_type { &print_content_type }
 #   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) {
@@ -252,6 +257,7 @@ sub print_content_type {
     } else {
         $type = 'text/html';
     }
+    $type .= "; charset=$charset" if $charset && $charset =~ m|^[\w\-\.\:\+]+$|;
 
     if (my $r = $self->apache_request) {
         return if $r->bytes_sent;
@@ -435,7 +441,9 @@ sub send_status {
             $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";
@@ -478,7 +486,7 @@ sub print_js {
 
     ### 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;
@@ -913,6 +921,14 @@ else already printed content-type).  Calling this sends the Content-type
 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({}).
@@ -963,6 +979,10 @@ that the javascript will cache.  Takes either a full filename,
 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
@@ -1031,14 +1051,12 @@ See also L<CGI::Ex::Template>.
 
 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