1 |
#!/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 |
} |