X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-CGI-Ex;a=blobdiff_plain;f=lib%2FCGI%2FEx.pm;h=1ce99a222c746ac2effb3dea1aa6b672783bae8d;hp=4b3b8a86493fe87c89cf68e00e2d51ddfbeccae6;hb=HEAD;hpb=b6e904ff7b346908d0662aae9a9c5f7d976dd85e

diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm
index 4b3b8a8..1ce99a2 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 2007 - Paul Seamons                                     #
+#  Copyright 2003-2012 - Paul Seamons                                #
 #  Distributed under the Perl Artistic License without warranty      #
 ###----------------------------------------------------------------###
 
@@ -19,12 +19,13 @@ use vars qw($VERSION
             $PREFERRED_CGI_REQUIRED
             $AUTOLOAD
             $DEBUG_LOCATION_BOUNCE
+            $CURRENT
             @EXPORT @EXPORT_OK
             );
 use base qw(Exporter);
 
 BEGIN {
-    $VERSION               = '2.17';
+    $VERSION               = '2.37';
     $PREFERRED_CGI_MODULE  ||= 'CGI';
     @EXPORT = ();
     @EXPORT_OK = qw(get_form
@@ -163,7 +164,7 @@ sub make_form {
         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/ /+/;
@@ -195,7 +196,7 @@ sub get_cookies {
     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;
 }
@@ -218,6 +219,39 @@ sub cookies {
 
 ###----------------------------------------------------------------###
 
+### 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);
@@ -240,6 +274,30 @@ 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>;
+    }
+}
+
+### Portable method for getting environment variables
+sub env {
+    my $self = shift || __PACKAGE__->new;
+
+    $self->is_psgi ? $self->object->env : \%ENV;
+}
+
+###----------------------------------------------------------------###
+
 ### same signature as print_content_type
 sub content_type { &print_content_type }
 
@@ -259,7 +317,13 @@ sub print_content_type {
     }
     $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;
@@ -278,7 +342,9 @@ sub print_content_type {
 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;
@@ -297,11 +363,14 @@ sub location_bounce {
 
     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) {
@@ -346,17 +415,17 @@ sub set_cookie {
     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";
     }
 }
 
@@ -376,7 +445,9 @@ sub last_modified {
     $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);
@@ -417,7 +488,7 @@ sub time_calc {
         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];
     }
 }
@@ -434,7 +505,10 @@ sub send_status {
     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');
@@ -460,7 +534,9 @@ sub send_header {
     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 {
@@ -486,7 +562,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;
@@ -501,7 +577,7 @@ sub print_js {
         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;
     }
@@ -513,13 +589,13 @@ sub print_js {
         $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;
 }
 
@@ -979,6 +1055,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