From: Rafael Kitover Date: Sat, 28 Jun 2008 11:15:53 +0000 (+0000) Subject: Working on a dist for WrapCGI... X-Git-Tag: 0.030~67 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Controller-WrapCGI.git;a=commitdiff_plain;h=32b32c6209c69a810c2d0b66a8cfc6efcae66d32 Working on a dist for WrapCGI... --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..39811e5 --- /dev/null +++ b/Changes @@ -0,0 +1,2 @@ +Revision history for Catalyst-Controller-WrapCGI + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..1652858 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,10 @@ +Changes +MANIFEST +Makefile.PL +README +lib/Catalyst/Controller/WrapCGI.pm +lib/Catalyst/Plugin/CGIBin.pm +lib/CatalystX/GlobalContext.pm +t/00-load.t +t/pod-coverage.t +t/pod.t diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..fc28bc7 --- /dev/null +++ b/META.yml @@ -0,0 +1,24 @@ +--- +abstract: 'Run CGIs in Catalyst' +author: + - 'Matt S. Trout ' +build_requires: + Test::More: 0 +distribution_type: module +generated_by: 'Module::Install version 0.75' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 +name: Catalyst-Controller-WrapCGI +no_index: + directory: + - inc + - t +requires: + Catalyst: 5.7007 + HTTP::Request::AsCGI: 0 + Task::Weaken: 0 + URI: 0 + parent: 0 +version: 0.001 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..eea901c --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,17 @@ +use inc::Module::Install; + +name 'Catalyst-Controller-WrapCGI'; +all_from 'lib/Catalyst/Controller/WrapCGI.pm'; +author 'Matt S. Trout '; + +requires 'Catalyst' => '5.7007'; +requires 'parent'; +requires 'Task::Weaken'; +requires 'HTTP::Request::AsCGI'; +requires 'URI'; + +build_requires 'Test::More'; + +auto_install; + +WriteAll; diff --git a/README b/README new file mode 100644 index 0000000..8a33885 --- /dev/null +++ b/README @@ -0,0 +1,43 @@ +Catalyst-Controller-WrapCGI + +Some modules to help you port mod_perl/CGI code to Catalyst. + +INSTALLATION + +To install this module, run the following commands: + + perl Makefile.PL + make + make test + make install + +SUPPORT AND DOCUMENTATION + +After installing, you can find documentation for these modules with the +perldoc command. + + perldoc Catalyst::Plugin::CGIBin + perldoc Catalyst::Controller::WrapCGI + perldoc CatalystX::GlobalContext + +You can also look for information at: + + RT, CPAN's request tracker + http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Controller-WrapCGI + + AnnoCPAN, Annotated CPAN documentation + http://annocpan.org/dist/Catalyst-Controller-WrapCGI + + CPAN Ratings + http://cpanratings.perl.org/d/Catalyst-Controller-WrapCGI + + Search CPAN + http://search.cpan.org/dist/Catalyst-Controller-WrapCGI + + +COPYRIGHT AND LICENCE + +Copyright (C) 2008 Matt S. Trout + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. diff --git a/lib/Catalyst/Controller/WrapCGI.pm b/lib/Catalyst/Controller/WrapCGI.pm index 169725e..3e9d117 100644 --- a/lib/Catalyst/Controller/WrapCGI.pm +++ b/lib/Catalyst/Controller/WrapCGI.pm @@ -1,21 +1,59 @@ package Catalyst::Controller::WrapCGI; -# AUTHOR: Matt S Trout, mst@shadowcatsystems.co.uk -# Original development sponsored by http://www.altinity.com/ - use strict; use warnings; -use base 'Catalyst::Controller'; +use parent 'Catalyst::Controller'; use HTTP::Request::AsCGI; use HTTP::Request; -use URI::Escape; +use URI; + +=head1 NAME + +Catalyst::Controller::WrapCGI - Run CGIs in Catalyst + +=head1 VERSION + +Version 0.001 + +=cut + +our $VERSION = '0.001'; + +=head1 SYNOPSIS + + package MyApp::Controller::Foo; + + use parent qw/Catalyst::Controller::WrapCGI/; + + sub hello : Path('cgi-bin/hello.cgi') { + my ($self, $c) = @_; + + $self->cgi_to_response($c, sub { + use CGI ':standard'; + + print header, start_html('Hello'), + h1('Catalyst Rocks!'), + end_html; + }); + } + +=cut # Hack-around because Catalyst::Engine::HTTP goes and changes # them to be the remote socket, and FCGI.pm does even dumber things. -open(*REAL_STDIN, "<&=".fileno(*STDIN)); -open(*REAL_STDOUT, ">>&=".fileno(*STDOUT)); +open my $REAL_STDIN, "<&=".fileno(*STDIN); +open my $REAL_STDOUT, ">>&=".fileno(*STDOUT); + +=head1 METHODS + +=head2 $self->cgi_to_response($c, $coderef) + +Does the magic of running $coderef in a CGI environment, and populating the +appropriate parts of your Catalyst context with the results. + +=cut sub cgi_to_response { my ($self, $c, $script) = @_; @@ -24,7 +62,9 @@ sub cgi_to_response { # if the CGI doesn't set the response code but sets location they were # probably trying to redirect so set 302 for them - if (length($res->headers->header('Location')) && $res->code == 200) { + my $location = $res->headers->header('Location'); + + if (defined $location && length $location && $res->code == 200) { $c->res->status(302); } else { $c->res->status($res->code); @@ -33,6 +73,17 @@ sub cgi_to_response { $c->res->headers($res->headers); } +=head2 $self->wrap_cgi($c, $coderef) + +Runs $coderef in a CGI environment using L, returns an +L. + +The CGI environment is set up based on $c. + +Used by cgi_to_response, which is probably what you want to use as well. + +=cut + sub wrap_cgi { my ($self, $c, $call) = @_; my $req = HTTP::Request->new( @@ -47,38 +98,30 @@ sub wrap_cgi { local $/; $body_content = <$body>; } else { my $body_params = $c->req->body_parameters; - if (keys %$body_params) { - my @parts; - foreach my $key (keys %$body_params) { - my $raw = $body_params->{$key}; - foreach my $value (ref $raw ? @$raw : ($raw)) { - push(@parts, join('=', map { uri_escape($_) } ($key, $value))); - } - } - $body_content = join('&', @parts); + if (%$body_params) { + my $encoder = URI->new; + $encoder->query_form(%$body_params); + $body_content = $encoder->query; $req->content_type('application/x-www-form-urlencoded'); } } - #warn "Body type: ".$req->content_type; - #warn "Body: ${body_content}"; - $req->content($body_content); $req->content_length(length($body_content)); my $user = (($c->can('user_exists') && $c->user_exists) - ? $c->user_object->username + ? eval { $c->user->obj->username } : ''); my $env = HTTP::Request::AsCGI->new( $req, REMOTE_USER => $user, - PERL5LIB => $ENV{PERL5LIB} # propagate custom perl lib paths + %ENV ); { - local *STDIN = \*REAL_STDIN; # restore the real ones so the filenos - local *STDOUT = \*REAL_STDOUT; # are 0 and 1 for the env setup + local *STDIN = $REAL_STDIN; # restore the real ones so the filenos + local *STDOUT = $REAL_STDOUT; # are 0 and 1 for the env setup - my $old = select(REAL_STDOUT); # in case somebody just calls 'print' + my $old = select($REAL_STDOUT); # in case somebody just calls 'print' my $saved_error; @@ -96,4 +139,55 @@ sub wrap_cgi { return $env->response; } -1; +=head1 ACKNOWLEDGEMENTS + +Original development sponsored by L + +=head1 AUTHOR + +Matt S. Trout, C<< >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at +L. +I will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + +=head1 SUPPORT + +More information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + +=head1 COPYRIGHT & LICENSE + +Copyright (c) 2008 Matt S. Trout + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1; # End of Catalyst::Controller::WrapCGI + +# vim: expandtab shiftwidth=4 ts=4 tw=80: diff --git a/lib/Catalyst/Plugin/CGIBin.pm b/lib/Catalyst/Plugin/CGIBin.pm new file mode 100644 index 0000000..a926bd7 --- /dev/null +++ b/lib/Catalyst/Plugin/CGIBin.pm @@ -0,0 +1,89 @@ +package Catalyst::Plugin::CGIBin; + +use strict; +use warnings; + +=head1 NAME + +Catalyst::Plugin::CGIBin - Server CGIs from root/cgi-bin + +=head1 VERSION + +Version 0.001 + +=cut + +our $VERSION = '0.001'; + + +=head1 SYNOPSIS + +In your .conf: + + controller MyApp::Controller::Foo + + + + + pass_env PERL5LIB + pass_env PATH + + + +=head1 DESCRIPTION + +Dispatches to CGI files in root/cgi-bin through the configured controller, which +must inherit from L. + +I still need to write the code :) + +=cut + +=head1 AUTHOR + +Rafael Kitover, C<< >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at +L. +I will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + +=head1 SUPPORT + +More information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + +=head1 COPYRIGHT & LICENSE + +Copyright (c) 2008 Rafael Kitover + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1; # End of Catalyst::Plugin::CGIBin + +# vim: expandtab shiftwidth=4 ts=4 tw=80: diff --git a/lib/CatalystX/Controller/WrapCGI.pm b/lib/CatalystX/Controller/WrapCGI.pm deleted file mode 100644 index 113c688..0000000 --- a/lib/CatalystX/Controller/WrapCGI.pm +++ /dev/null @@ -1,93 +0,0 @@ -package CatalystX::Controller::WrapCGI; - -# AUTHOR: Matt S Trout, mst@shadowcatsystems.co.uk -# Original development sponsored by http://www.altinity.com/ - -use strict; -use warnings; -use base 'Catalyst::Controller'; - -use HTTP::Request::AsCGI; -use HTTP::Request; -use URI; - -# Hack-around because Catalyst::Engine::HTTP goes and changes -# them to be the remote socket, and FCGI.pm does even dumber things. - -open(*REAL_STDIN, "<&=".fileno(*STDIN)); -open(*REAL_STDOUT, ">>&=".fileno(*STDOUT)); - -sub cgi_to_response { - my ($self, $c, $script) = @_; - my $res = $self->wrap_cgi($c, $script); - - # if the CGI doesn't set the response code but sets location they were - # probably trying to redirect so set 302 for them - - my $location = $res->headers->header('Location'); - - if (defined $location && length $location && $res->code == 200) { - $c->res->status(302); - } else { - $c->res->status($res->code); - } - $c->res->body($res->content); - $c->res->headers($res->headers); -} - -sub wrap_cgi { - my ($self, $c, $call) = @_; - my $req = HTTP::Request->new( - map { $c->req->$_ } qw/method uri headers/ - ); - my $body = $c->req->body; - my $body_content = ''; - - $req->content_type($c->req->content_type); # set this now so we can override - - if ($body) { # Slurp from body filehandle - local $/; $body_content = <$body>; - } else { - my $body_params = $c->req->body_parameters; - if (%$body_params) { - my $encoder = URI->new; - $encoder->query_form(%$body_params); - $body_content = $encoder->query; - $req->content_type('application/x-www-form-urlencoded'); - } - } - - $req->content($body_content); - $req->content_length(length($body_content)); - my $user = (($c->can('user_exists') && $c->user_exists) - ? eval { $c->user->obj->username } - : ''); - my $env = HTTP::Request::AsCGI->new( - $req, - REMOTE_USER => $user, - %ENV - ); - - { - local *STDIN = \*REAL_STDIN; # restore the real ones so the filenos - local *STDOUT = \*REAL_STDOUT; # are 0 and 1 for the env setup - - my $old = select(REAL_STDOUT); # in case somebody just calls 'print' - - my $saved_error; - - $env->setup; - eval { $call->() }; - $saved_error = $@; - $env->restore; - - select($old); - - warn "CGI invoke failed: $saved_error" if $saved_error; - - } - - return $env->response; -} - -1; diff --git a/lib/CatalystX/GlobalContext.pm b/lib/CatalystX/GlobalContext.pm new file mode 100644 index 0000000..579e08e --- /dev/null +++ b/lib/CatalystX/GlobalContext.pm @@ -0,0 +1,118 @@ +package CatalystX::GlobalContext; + +use strict; +use warnings; +use parent 'Exporter'; + +use Scalar::Util 'weaken'; + +=head1 NAME + +CatalystX::GlobalContext - Export Catalyst Context + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + +=head1 SYNOPSIS + + package MyApp::Controller::Root; + + use CatalystX::GlobalContext (); + + sub auto { + my ($self, $c) = @_; + CatalystX::GlobalContext->set_context($c); + 1; + } + + package Some::Other::Module; + + use CatalystX::GlobalContext '$c'; + + ... + do stuff with $c + ... + +=head1 DESCRIPTION + +This module, in combination with L is for helping +you run legacy mod_perl code in L. + +You save a copy of $c somewhere at the beginning of the request cycle, and it is +then accessible through an export where you need it. + +You can then rip out Apache:: type things, and replace them with things based on +$c. + +What we really need is a set of Apache:: compatibility classes, but that doesn't +exist yet. + +DO NOT USE THIS MODULE IN NEW CODE + +=head1 CLASS METHODS + +=head2 CatalystX::GlobalContext->set_context($c) + +Saves a weakened reference to the Catalyst context, +which is accessible from other modules as an export. + +=cut + +sub set_context { + $c = $_[1]; + weaken $c; +} + +=head1 AUTHOR + +Rafael Kitover, C<< >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at +L. +I will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + +=head1 SUPPORT + +More information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + +=head1 COPYRIGHT & LICENSE + +Copyright (c) 2008 Rafael Kitover + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1; # End of CatalystX::GlobalContext + +# vim: expandtab shiftwidth=4 ts=4 tw=80: