| 1 |
dpavlin |
5 |
#!/usr/bin/perl |
| 2 |
|
|
|
| 3 |
|
|
# based on post |
| 4 |
|
|
# http://www.mail-archive.com/libwww@perl.org/msg04750.html |
| 5 |
|
|
|
| 6 |
|
|
use strict; |
| 7 |
|
|
use warnings; |
| 8 |
|
|
use HTTP::Daemon; |
| 9 |
|
|
use HTTP::Status; |
| 10 |
|
|
use IO::String; |
| 11 |
|
|
use CGI 2.50 qw/:standard :cgi-lib/; |
| 12 |
|
|
|
| 13 |
|
|
my $d = HTTP::Daemon->new( Reuse => 1, LocalPort => 6969 ) || die; |
| 14 |
|
|
print "Please contact me at: <URL:", $d->url, ">\n"; |
| 15 |
|
|
|
| 16 |
|
|
while ( my $c = $d->accept ) { |
| 17 |
|
|
while ( my $r = $c->get_request ) { |
| 18 |
|
|
|
| 19 |
|
|
# environs that a webserver should set. |
| 20 |
|
|
$ENV{'REQUEST_METHOD'} = $r->method; |
| 21 |
|
|
$ENV{'GATEWAY_INTERFACE'} = "CGI/1.0"; |
| 22 |
|
|
$ENV{'SERVER_PROTOCOL'} = $r->protocol; |
| 23 |
|
|
$ENV{'CONTENT_TYPE'} = $r->content_type; |
| 24 |
|
|
|
| 25 |
|
|
my $form_parameters; # GET/POST storage. |
| 26 |
|
|
|
| 27 |
|
|
# is this a happy GET? |
| 28 |
|
|
if ( $r->method eq 'GET' || $r->uri =~ /\?/ ) { |
| 29 |
|
|
$form_parameters = $r->uri; |
| 30 |
|
|
$form_parameters =~ s/[^\?]+\?(.*)/$1/; |
| 31 |
|
|
$CGI::Q = new CGI($form_parameters); |
| 32 |
|
|
} |
| 33 |
|
|
|
| 34 |
|
|
# possibly POST? |
| 35 |
|
|
if ( $r->method eq 'POST' ) { |
| 36 |
|
|
|
| 37 |
|
|
# now decide how we want to turn the parameters |
| 38 |
|
|
# over to CGI.pm. note that this will cause |
| 39 |
|
|
# problems with your STDIN with multipart forms. |
| 40 |
|
|
my $form_parameters = $r->content; |
| 41 |
|
|
$ENV{'CONTENT_LENGTH'} = $r->content_length || 0; |
| 42 |
|
|
|
| 43 |
|
|
# sounds like multipart. |
| 44 |
|
|
if ( $form_parameters =~ /^--/ ) { |
| 45 |
|
|
|
| 46 |
|
|
my ($boundary) = split ( /\n/, $form_parameters ); |
| 47 |
|
|
chop($boundary); |
| 48 |
|
|
substr( $boundary, 0, 2 ) = ''; # delete the leading "--" !!! |
| 49 |
|
|
$ENV{'CONTENT_TYPE'} = |
| 50 |
|
|
$r->content_type . "; boundary=$boundary"; |
| 51 |
|
|
|
| 52 |
|
|
# this breaks STDIN forever. I've yet to discover |
| 53 |
|
|
# how to properly save and reassign STDIN after |
| 54 |
|
|
# we're done breaking things horrifically here. |
| 55 |
|
|
close STDIN; |
| 56 |
|
|
my $t = tie *STDIN, 'IO::String'; |
| 57 |
|
|
$t->open($form_parameters); |
| 58 |
|
|
$CGI::Q = new CGI(); |
| 59 |
|
|
} |
| 60 |
|
|
|
| 61 |
|
|
else { $CGI::Q = new CGI($form_parameters); } |
| 62 |
|
|
} |
| 63 |
|
|
|
| 64 |
|
|
if (! $CGI::Q) { |
| 65 |
|
|
$c->send_error(RC_FORBIDDEN); |
| 66 |
|
|
} |
| 67 |
|
|
|
| 68 |
|
|
my $param = param("hello") || ''; |
| 69 |
|
|
my $url = $r->url->path; |
| 70 |
|
|
|
| 71 |
|
|
print "I saw: $param\n"; |
| 72 |
|
|
|
| 73 |
|
|
# my $f = param("thefile"); |
| 74 |
|
|
# print "thefile filename: $f\n"; |
| 75 |
|
|
# { undef $/; print "thefile size: ", length(<$f>), "\n" } |
| 76 |
|
|
|
| 77 |
|
|
my $res = HTTP::Response->new(RC_OK); |
| 78 |
|
|
$res->content( qq{ |
| 79 |
|
|
<html> |
| 80 |
|
|
hello = $param<br> |
| 81 |
|
|
URL: $url |
| 82 |
|
|
</html> |
| 83 |
|
|
} |
| 84 |
|
|
); |
| 85 |
|
|
|
| 86 |
|
|
$c->send_response($res); |
| 87 |
|
|
|
| 88 |
|
|
$c->close; |
| 89 |
|
|
} |
| 90 |
|
|
undef($c); |
| 91 |
|
|
} |
Parent Directory
| 
Revision Log