our
$VERSION
=
'0.03'
;
sub
_open_socket
{
my
$frompid
= $$;
$frompid
%= 63 * 1024;
$frompid
+= 63 * 1024
if
$frompid
< 1024;
my
$port
=
$ENV
{HTTP_PORT} ||
$frompid
;
foreach
( 0..100 ) {
my
$socket
= IO::Socket::INET->new(
Proto
=>
'tcp'
,
LocalPort
=>
$port
,
Listen
=> 5,
Reuse
=> 1,
Blocking
=> 1,
);
return
(
$port
,
$socket
)
if
$socket
;
$port
= 1024 +
int
rand
63 * 1024;
}
}
sub
new
{
my
$class
=
shift
;
my
(
$port
,
$socket
) = _open_socket()
or
die
"Could not start HTTP server\n"
;
my
$pid
=
fork
;
die
"Could not fork\n"
unless
defined
$pid
;
if
(
$pid
) {
my
$self
= {
address
=>
"127.0.0.1"
,
port
=>
$port
,
pid
=>
$pid
,
};
return
bless
$self
,
$class
;
}
else
{
$SIG
{CHLD} = \
&_sigchld
;
_main_loop(
$socket
,
@_
);
exec
"true"
;
die
"Should not be here\n"
;
}
}
sub
uri
{
my
$self
=
shift
;
return
"http://$self->{address}:$self->{port}/"
;
}
sub
port
{
my
$self
=
shift
;
$self
->{port};
}
sub
address
{
my
$self
=
shift
;
if
(
@_
) {
$self
->{address} =
shift
;
}
$self
->{address};
}
sub
_sigchld
{
my
$kid
;
local
$?;
do
{
$kid
=
waitpid
-1, WNOHANG;
}
while
(
$kid
> 0 );
}
sub
DESTROY
{
my
$self
=
shift
;
my
$done
= 0;
local
$SIG
{CHLD} = \
&_sigchld
;
my
$cnt
=
kill
15,
$self
->{pid};
return
unless
$cnt
;
foreach
my
$sig
( 15, 15, 15, 9, 9, 9 ) {
$cnt
=
kill
$sig
,
$self
->{pid};
last
unless
$cnt
;
select
undef
,
undef
,
undef
, 0.1;
}
}
sub
_term
{
exec
"true"
;
die
"Should not be here\n"
;
}
sub
_main_loop
{
my
$socket
=
shift
;
$SIG
{TERM} = \
&_term
;
for
(;;) {
my
$client
=
$socket
->
accept
()
or
redo
;
my
$pid
=
fork
;
die
"Could not fork\n"
unless
defined
$pid
;
if
(
$pid
) {
close
$client
;
}
else
{
Test::HTTP::Server::Request->
open
(
$client
,
@_
);
_term();
}
}
}
BEGIN {
eval
{
URI::Escape->
import
(
qw(uri_unescape)
);
};
if
( $@ ) {
*uri_unescape
=
sub
{
local
$_
=
shift
;
s/%(..)/
chr
hex
$1/eg;
return
$_
;
};
}
}
use
constant
DNAME
=> [
qw(Sun Mon Tue Wed Thu Fri Sat)
];
use
constant
MNAME
=> [
qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)
];
sub
_http_time
{
my
$self
=
shift
;
my
@t
=
gmtime
(
shift
||
time
);
return
sprintf
'%s, %02d %s %04d %02d:%02d:%02d GMT'
,
DNAME->[
$t
[6] ],
$t
[3], MNAME->[
$t
[4] ], 1900+
$t
[5],
$t
[2],
$t
[1],
$t
[0];
}
sub
open
{
my
$class
=
shift
;
my
$socket
=
shift
;
open
STDOUT,
'>&'
,
$socket
;
open
STDIN,
'<&'
,
$socket
;
my
$self
= {
version
=>
"1.0"
,
@_
,
socket
=>
$socket
,
};
bless
$self
,
$class
;
$self
->process;
}
sub
process
{
my
$self
=
shift
;
$self
->in_all;
$self
->out_all;
close
STDIN;
close
STDOUT;
close
$self
->{
socket
};
}
sub
in_all
{
my
$self
=
shift
;
$self
->{request} =
$self
->in_request;
$self
->{headers} =
$self
->in_headers;
if
(
$self
->{request}->[0] =~ /^(?:POST|PUT)/ ) {
$self
->{body} =
$self
->in_body;
}
else
{
delete
$self
->{body};
}
}
sub
in_request
{
my
$self
=
shift
;
local
$/ =
"\r\n"
;
$_
= <STDIN>;
$self
->{head} =
$_
;
chomp
;
return
[
split
/\s+/,
$_
];
}
sub
in_headers
{
my
$self
=
shift
;
local
$/ =
"\r\n"
;
my
@headers
;
while
( <STDIN> ) {
$self
->{head} .=
$_
;
chomp
;
last
unless
length
$_
;
s/(\S+):\s*//;
my
$header
= $1;
$header
=~
tr
/-/_/;
push
@headers
, (
lc
$header
,
$_
);
}
return
\
@headers
;
}
sub
in_body
{
my
$self
=
shift
;
my
%headers
= @{
$self
->{headers} };
$_
=
""
;
my
$len
=
$headers
{content_length};
$len
= 10 * 1024 * 1024
unless
defined
$len
;
read
STDIN,
$_
,
$len
;
return
$_
;
}
sub
out_response
{
my
$self
=
shift
;
my
$code
=
shift
;
print
"HTTP/$self->{version} $code\r\n"
;
}
sub
out_headers
{
my
$self
=
shift
;
while
(
my
(
$name
,
$value
) =
splice
@_
, 0, 2 ) {
$name
=
join
"-"
,
map
{
ucfirst
lc
$_
}
split
/[_-]+/,
$name
;
if
(
ref
$value
) {
foreach
my
$val
(
@$value
) {
print
"$name: $val\r\n"
;
}
}
else
{
print
"$name: $value\r\n"
;
}
}
}
sub
out_body
{
my
$self
=
shift
;
my
$body
=
shift
;
my
$len
=
length
$body
;
print
"Content-Length: $len\r\n"
;
print
"\r\n"
;
print
$body
;
}
sub
out_all
{
my
$self
=
shift
;
my
%default_headers
= (
content_type
=>
"text/plain"
,
date
=>
$self
->_http_time,
);
$self
->{out_headers} = {
%default_headers
};
my
$req
=
$self
->{request}->[1];
$req
=~ s
my
@args
=
map
{ uri_unescape
$_
}
split
m
my
$func
=
shift
@args
;
$func
=
"index"
unless
defined
$func
and
length
$func
;
my
$body
;
eval
{
$body
=
$self
->
$func
(
@args
);
};
if
( $@ ) {
warn
"Server error: $@\n"
;
$self
->out_response(
"404 Not Found"
);
$self
->out_headers(
%default_headers
);
$self
->out_body(
"Server error: $@\n"
);
}
elsif
(
defined
$body
) {
$self
->out_response(
$self
->{out_code} ||
"200 OK"
);
$self
->out_headers( %{
$self
->{out_headers} } );
$self
->out_body(
$body
);
}
}
sub
index
{
my
$self
=
shift
;
my
$body
=
"Available functions:\n"
;
$body
.= (
join
""
,
map
"- $_\n"
,
sort
{
$a
cmp
$b
}
grep
{ not __PACKAGE__->can(
$_
) }
grep
{ Test::HTTP::Server::Request->can(
$_
) }
keys
%{Test::HTTP::Server::Request::} )
||
"NONE\n"
;
return
$body
;
}
sub
echo
{
my
$self
=
shift
;
my
$type
=
shift
;
my
$body
=
""
;
if
( not
$type
or
$type
eq
"head"
) {
$body
.=
$self
->{head};
}
if
( ( not
$type
or
$type
eq
"body"
) and
defined
$self
->{body} ) {
$body
.=
$self
->{body};
}
return
$body
;
}
sub
cookie
{
my
$self
=
shift
;
my
$num
=
shift
|| 1;
my
$template
=
shift
||
"test_cookie%n=true; expires=%date(+600); path=/"
;
my
$expdate
=
sub
{
my
$time
=
shift
;
$time
+=
time
if
$time
=~ m/^[+-]/;
return
$self
->_http_time(
$time
);
};
my
@cookies
;
foreach
my
$n
( 1..
$num
) {
$_
=
$template
;
s/
%n
/
$n
/;
s/
%date
\(\s*([+-]?\d+)\s*\)/
$expdate
->( $1 )/e;
push
@cookies
,
$_
;
}
$self
->{out_headers}->{set_cookie} = \
@cookies
;
return
"Sent $num cookies matching template:\n$template\n"
;
}
sub
repeat
{
my
$self
=
shift
;
my
$num
=
shift
|| 1024;
my
$pattern
=
shift
||
"="
;
return
$pattern
x
$num
;
}
our
@ISA
=
qw(Test::HTTP::Server::Connection)
;
1;