Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

implemented Squatting::On::CGI

  • Loading branch information...
commit de1a78d39bd40d5d93fefbee8a1f61a9f7793653 1 parent f428479
John Beppu authored
Showing with 97 additions and 1 deletion.
  1. +1 −1  Changes
  2. +1 −0  MANIFEST
  3. +95 −0 lib/Squatting/On/CGI.pm
View
2  Changes
@@ -1,5 +1,5 @@
0.60 (unreleased)
- * Squatting::On::CGI
+ - implemented Squatting::On::CGI
0.50
- More documentation updates and corrections.
View
1  MANIFEST
@@ -23,6 +23,7 @@ lib/Squatting/Controller.pm
lib/Squatting/Cookbook.pod
lib/Squatting/Mapper.pm
lib/Squatting/On/Catalyst.pm
+lib/Squatting/On/CGI.pm
lib/Squatting/On/Continuity.pm
lib/Squatting/View.pm
lib/Squatting/With/AccessTrace.pm
View
95 lib/Squatting/On/CGI.pm
@@ -0,0 +1,95 @@
+package Squatting::On::CGI;
+
+use strict;
+no strict 'refs';
+use warnings;
+use CGI;
+use HTTP::Response;
+use Data::Dump 'pp';
+
+# p for private
+my %p;
+$p{init_cc} = sub {
+ my ($c, $q) = @_;
+ my $cc = $c->clone;
+ $cc->env = { %ENV };
+ $cc->input = $p{i}->($q);
+ $cc->v = { };
+ $cc->headers = { 'Content-Type' => 'text/html' };
+ $cc->status = 200;
+ $cc;
+};
+
+# \%input = i($q) # Extract CGI parameters from a CGI object
+$p{i} = sub {
+ my $q = $_[0];
+ my %i = $q->Vars;
+ +{ map {
+ if ($i{$_} =~ /\0/) {
+ $_ => [ split("\0", $i{$_}) ];
+ } else {
+ $_ => $i{$_};
+ }
+ } keys %i }
+};
+
+sub cgi {
+ my ($app, $q) = @_;
+ $ENV{PATH_INFO} ||= '/';
+ $ENV{REQUEST_PATH} ||= do {
+ my $script_name = $ENV{SCRIPT_NAME};
+ $script_name =~ s{/$}{};
+ $script_name . $ENV{PATH_INFO};
+ };
+ $ENV{REQUEST_URI} ||= do {
+ ($ENV{QUERY_STRING})
+ ? "$ENV{REQUEST_PATH}?$ENV{QUERY_STRING}"
+ : $ENV{REQUEST_PATH};
+ };
+ eval {
+ my ($c, $args) = &{$app."::D"}($ENV{REQUEST_PATH});
+ my $cc = $p{init_cc}->($c, $q);
+ my $content = $app->service($cc, @$args);
+ my $response = HTTP::Response->new(
+ $cc->status,
+ HTTP::Status::status_message($cc->status),
+ [ %{ $cc->{headers} } ],
+ $content
+ );
+ print $response->as_string;
+ };
+ if ($@) {
+ print $q->header;
+ print "<pre>$@</pre>";
+ }
+}
+
+1;
+
+=head1 NAME
+
+Squatting::On::CGI - if all else fails, you can still deploy on CGI
+
+=head1 SYNOPSIS
+
+Create an app.cgi
+
+ use App 'On::CGI';
+ my $q = CGI->new;
+ App->init;
+ App->relocate('/app.cgi');
+ App->cgi($q);
+
+=head1 DESCRIPTION
+
+If all else fails, you can still deploy on CGI.
+
+=head1 API
+
+=head2 The Lowest Common Demoninator
+
+=head3 App->cgi($q)
+
+Give the C<cgi> method a CGI object, and it'll take care of everything else.
+
+=cut
Please sign in to comment.
Something went wrong with that request. Please try again.