![(please configure the [header_logo] section in trac.ini)](/share/chrome/site/your_project_logo.png){kind=logo}
Changeset 17851
- Timestamp:
- 08/18/08 22:20:57 (5 years ago)
- Location:
- lang/perl/HTTP-Engine/trunk
- Files:
-
- 5 modified
-
Makefile.PL (modified) (1 diff)
-
t/020_interface/poe.t (modified) (1 diff)
-
t/020_interface/server_simple.t (modified) (1 diff)
-
t/FCGIUtils.pm (modified) (5 diffs)
-
t/Utils.pm (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
lang/perl/HTTP-Engine/trunk/Makefile.PL
r17830 r17851 85 85 build_requires 'File::Temp' => '0.20'; 86 86 build_requires 'HTTP::Request::AsCGI'; 87 build_requires 'Test::TCP'; 87 88 88 89 use_test_base; -
lang/perl/HTTP-Engine/trunk/t/020_interface/poe.t
r17765 r17851 2 2 use warnings; 3 3 use Test::More; 4 use t::Utils;4 use Test::TCP; 5 5 use HTTP::Engine; 6 6 -
lang/perl/HTTP-Engine/trunk/t/020_interface/server_simple.t
r17748 r17851 2 2 use warnings; 3 3 use Test::More; 4 use t::Utils;5 4 eval "use HTTP::Server::Simple"; 6 5 plan skip_all => 'this test requires HTTP::Server::Simple' if $@; 7 6 plan tests => 2; 8 7 use LWP::UserAgent; 9 use HTTP::Request::Common qw(POST $DYNAMIC_FILE_UPLOAD);8 use HTTP::Request::Common qw(POST); 10 9 use HTTP::Engine; 11 use t::Utils;10 use Test::TCP; 12 11 13 my $port = empty_port; 14 15 &main; exit(); 16 17 sub main { 18 daemonize( 19 \&_do_request, 20 $port, 21 interface => { 22 module => 'ServerSimple', 23 args => { 24 port => $port, 12 test_tcp( 13 client => sub { 14 my $port = shift; 15 my $ua = LWP::UserAgent->new(timeout => 10); 16 my $req = POST("http://localhost:$port/", Content_Type => 'multipart/form-data;', Content => ['test' => ["README"]]); 17 my $res = $ua->request($req); 18 is $res->code, 200; 19 like $res->content, qr{Kazuhiro Osawa}; 20 }, 21 server => sub { 22 my $port = shift; 23 HTTP::Engine->new( 24 interface => { 25 module => 'ServerSimple', 26 args => { 27 port => $port, 28 }, 29 request_handler => sub { 30 my $req = shift; 31 HTTP::Engine::Response->new(body => $req->upload("test")->slurp(), status => 200); 32 }, 25 33 }, 26 request_handler => sub { 27 my $req = shift; 28 HTTP::Engine::Response->new(body => $req->upload("test")->slurp(), status => 200); 29 }, 30 }, 31 ); 32 } 33 34 sub _do_request { 35 my $port = shift; 36 my $ua = LWP::UserAgent->new(timeout => 10); 37 my $req = POST("http://localhost:$port/", Content_Type => 'multipart/form-data;', Content => ['test' => ["README"]]); 38 my $res = $ua->request($req); 39 is $res->code, 200; 40 like $res->content, qr{Kazuhiro Osawa}; 41 } 42 34 )->run; 35 }, 36 ); -
lang/perl/HTTP-Engine/trunk/t/FCGIUtils.pm
r17747 r17851 2 2 use strict; 3 3 use warnings; 4 use t::Utils;5 4 use File::Temp (); 6 5 use FindBin; … … 8 7 use IO::Socket; 9 8 use File::Spec; 9 use Test::TCP qw/test_tcp empty_port/; 10 10 11 11 # this file is copied from Catalyst. thanks! … … 18 18 sub test_lighty ($&) { 19 19 my ($fcgisrc, $callback, $port) = @_; 20 $port ||= empty_port ;20 $port ||= empty_port(); 21 21 22 22 plan skip_all => 'set TEST_LIGHTTPD to enable this test' … … 34 34 my $tmpdir = File::Temp::tempdir(); 35 35 36 my $fcgifname = File::Spec->catfile($tmpdir, "test.fcgi"); 37 do { 38 _write_file($fcgifname => $fcgisrc); 39 chmod 0777, $fcgifname; 40 warn `perl -wc $fcgifname` if $ENV{DEBUG}; 41 }; 36 test_tcp( 37 client => sub { 38 my $port = shift; 39 $callback->($port); 40 warn `cat $tmpdir/error.log` if $ENV{DEBUG}; 41 }, 42 server => sub { 43 my $port = shift; 42 44 43 my $conf = <<"END"; 45 my $fcgifname = File::Spec->catfile($tmpdir, "test.fcgi"); 46 do { 47 _write_file($fcgifname => $fcgisrc); 48 chmod 0777, $fcgifname; 49 warn `perl -wc $fcgifname` if $ENV{DEBUG}; 50 }; 51 52 my $conffname = File::Spec->catfile($tmpdir, "lighty.conf"); 53 _write_file($conffname => _render_conf($tmpdir, $port, $fcgifname)); 54 55 my $pid = open my $lighttpd, "$lighttpd_bin -D -f $conffname 2>&1 |" 56 or die "Unable to spawn lighttpd: $!"; 57 $SIG{TERM} = sub { 58 kill 'INT', $pid; 59 close $lighttpd; 60 exit; 61 }; 62 sleep 60; # waiting tests. 63 die "server timeout"; 64 }, 65 port => $port, 66 ); 67 } 68 69 sub _write_file { 70 my ($fname, $src) = @_; 71 open my $fh, '>', $fname or die $!; 72 print {$fh} $src or die $!; 73 close $fh; 74 } 75 76 sub _render_conf { 77 my ($tmpdir, $port, $fcgifname) = @_; 78 <<"END"; 44 79 # basic lighttpd config file for testing fcgi+HTTP::Engine 45 80 server.modules = ( … … 74 109 ) 75 110 END 76 77 my $conffname = File::Spec->catfile($tmpdir, "lighty.conf");78 _write_file($conffname => $conf);79 80 my $pid = open my $lighttpd, "$lighttpd_bin -D -f $conffname 2>&1 |"81 or die "Unable to spawn lighttpd: $!";82 83 wait_port($port);84 85 $callback->($port);86 87 warn `cat $tmpdir/error.log` if $ENV{DEBUG};88 89 kill 'INT', $pid;90 close $lighttpd;91 }92 93 sub _write_file {94 my ($fname, $src) = @_;95 open my $fh, '>', $fname or die $!;96 print {$fh} $src or die $!;97 close $fh;98 111 } 99 112 -
lang/perl/HTTP-Engine/trunk/t/Utils.pm
r17823 r17851 6 6 use HTTP::Request::AsCGI; 7 7 use HTTP::Engine::RequestBuilder; 8 use Test::TCP qw/test_tcp empty_port/; 8 9 9 10 use IO::Socket::INET; 10 11 11 12 use Sub::Exporter -setup => { 12 exports => [qw/ empty_port daemonize daemonize_all interfaces run_engine ok_response check_port wait_portreq /],13 exports => [qw/ daemonize_all interfaces run_engine ok_response req /], 13 14 groups => { default => [':all'] } 14 15 }; 15 16 sub empty_port {17 my $port = shift || 10000;18 $port = 19000 unless $port =~ /^[0-9]+$/ && $port < 19000;19 20 while ($port++ < 20000) {21 my $sock = IO::Socket::INET->new(22 Listen => 5,23 LocalAddr => 'localhost',24 LocalPort => $port,25 Proto => 'tcp'26 );27 return $port if $sock;28 }29 die "empty port not found";30 }31 32 sub daemonize (&@) { goto \&_daemonize }33 sub _daemonize {34 my($client, $port, %args) = @_;35 __daemonize($client, $port, sub {36 my $poe_kernel_run = delete $args{poe_kernel_run};37 HTTP::Engine->new(%args)->run;38 POE::Kernel->run() if $poe_kernel_run;39 });40 }41 sub __daemonize {42 my($client, $port, $child) = @_;43 44 if (my $pid = fork()) {45 # parent.46 47 wait_port($port);48 49 $client->($port);50 51 kill TERM => $pid;52 waitpid($pid, 0);53 } elsif ($pid == 0) {54 # child55 $child->();56 } else {57 die "cannot fork";58 }59 }60 16 61 17 my @interfaces; # memoize. … … 74 30 my($client, $codesrc) = @_; 75 31 76 my $port = empty_port ;32 my $port = empty_port(); 77 33 78 34 my $code = eval $codesrc; … … 105 61 } elsif ($interface eq 'CGI') { 106 62 require HTTP::Server::Simple::CGI; 107 __daemonize $client_cb, $port, sub { 108 Moose::Meta::Class 109 ->create_anon_class( 110 superclasses => ['HTTP::Server::Simple::CGI'], 111 methods => { 112 handler => sub { 113 no warnings 'redefine'; 114 require HTTP::Engine::Interface::CGI; 115 local *HTTP::Engine::Interface::CGI::should_write_response_line = sub { 1 }; # H::S::S::CGI needs status line 116 $args{interface}->{module} = $interface; 117 HTTP::Engine->new( 118 %args 119 )->run; 63 test_tcp( 64 client => $client_cb, 65 server => sub { 66 Moose::Meta::Class 67 ->create_anon_class( 68 superclasses => ['HTTP::Server::Simple::CGI'], 69 methods => { 70 handler => sub { 71 no warnings 'redefine'; 72 require HTTP::Engine::Interface::CGI; 73 local *HTTP::Engine::Interface::CGI::should_write_response_line = sub { 1 }; # H::S::S::CGI needs status line 74 $args{interface}->{module} = $interface; 75 HTTP::Engine->new( 76 %args 77 )->run; 78 }, 120 79 }, 121 }, 122 cache => 1 123 )->new_object( 124 )->new( 125 $port 126 )->run; 127 }; 80 cache => 1 81 )->new_object( 82 )->new( 83 $port 84 )->run; 85 }, 86 port => $port, 87 ); 128 88 } else { 129 89 $args{interface}->{module} = $interface; 130 90 $args{poe_kernel_run} = ($interface eq 'POE') if $poe_kernel_run; 131 _daemonize $client_cb, $port, %args; 91 test_tcp( 92 client => $client_cb, 93 server => sub { 94 my $poe_kernel_run = delete $args{poe_kernel_run}; 95 HTTP::Engine->new(%args)->run; 96 POE::Kernel->run() if $poe_kernel_run; 97 }, 98 port => $port, 99 ); 132 100 } 133 101 } … … 153 121 } 154 122 155 sub check_port {156 my ( $port ) = @_;157 158 my $remote = IO::Socket::INET->new(159 Proto => "tcp",160 PeerAddr => '127.0.0.1',161 PeerPort => $port162 );163 if ($remote) {164 close $remote;165 return 1;166 }167 else {168 return 0;169 }170 }171 172 sub wait_port {173 my $port = shift;174 175 my $retry = 10;176 while ($retry--) {177 return if check_port($port);178 sleep 1;179 }180 die "cannot open port: $port";181 }182 183 123 sub req { 184 124 my %args = @_;
