Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris

CGI::Application + Net::HTTPServer

by gryphon (Abbot)
on Jun 06, 2005 at 04:36 UTC ( #463825=CUFP: print w/replies, xml ) Need Help??

Greetings fellow monks,

A while back, I posted about trying to wrap an existing CGI::Application web app inside a Net::HTTPServer script without making any modifications to the CGI::Application app's code. After some hacking, I think I've come up with something that mostly works. I've tested it for GET, POST, cookies, and redirects. It seems to do OK. There's one known bug: It doesn't save multiple cookies in a single request due to (what I think is) a bug in how Net::HTTPServer handles headers. So you can only save one cookie at a time for now.

#!/usr/bin/perl use strict; use warnings FATAL => 'all'; use Net::HTTPServer; my $httpd = Net::HTTPServer->new( 'port' => 8081, 'docroot' => 'htdocs', 'index' => ['index.html', '', 'index.cgi'], 'log' => 'STDOUT', 'type' => 'forking', 'type' => 'single', 'numproc' => 5 ); use CGI qw(-compile -oldstyle_urls); use YourCGIApplicationModule; sub yourapp { my $req = shift; my $res = $req->Response; $ENV{$_} = $req->Env($_) || '' foreach (keys(%{$req->Env()})); $ENV{HTTP_COOKIE} = join ('; ', map { $_ . '=' . $req->Cookie($_) +} keys %{$req->Cookie()}); my $your_cgi_app = YourCGIApplicationModule->new({ QUERY => CGI->new( ($req->Method eq 'GET') ? $req->Query : ($req->Request =~ /\n\W*\n([^\n]+)/) ? $ +1 : '' ) }); $res->CaptureSTDOUT; $your_cgi_app->run; $res->ProcessSTDOUT({ strip_header => 0 }); my ($headers, @content) = split(/\n\n/, $res->Body); my $code = 200; foreach (split(/\n/, $headers)) { if (/^(.*?): (.*)$/) { $res->Header($1, $2); $code = $1 if (($1 eq 'Status') and ($2 =~ /^(\d+)\s/)); } } $res->Code($code); $res->Body( join("\n\n", @content) ); return $res; } $httpd->RegisterURL({ '/yourapp' => \&yourapp }); $httpd->Start; $httpd->Process; $httpd->Stop; exit 0;

As always, I'm interested in any rewrites or suggestions you folks have. Thanks.

code('Perl') || die;

Janitored by holli - added readmore tags

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://463825]
Approved by Zaxo
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (4)
As of 2021-08-03 07:47 GMT
Find Nodes?
    Voting Booth?
    My primary motivation for participating at PerlMonks is: (Choices in context)

    Results (35 votes). Check out past polls.