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 |
|
|
} |