File Coverage

blib/lib/Nginx/Test.pm
Criterion Covered Total %
statement 240 330 72.7
branch 55 134 41.0
condition 9 36 25.0
subroutine 30 37 81.0
pod 18 21 85.7
total 352 558 63.0


line stmt bran cond sub pod time code
1             package Nginx::Test;
2              
3             our $VERSION = '1.2.9.7';
4              
5              
6             =head1 NAME
7              
8             Nginx::Test - testing framework for nginx-perl and nginx
9              
10             =head1 SYNOPSIS
11              
12             use Nginx::Test;
13            
14             my $nginx = find_nginx_perl;
15             my $dir = make_path 'tmp/test';
16            
17             my ($child, $peer) =
18             fork_nginx_handler_die $nginx, $dir, '', <<'END';
19            
20             sub handler {
21             my $r = shift;
22             ...
23            
24             return OK;
25             }
26            
27             END
28            
29             wait_for_peer $peer, 2
30             or die "peer never started\n";
31            
32             my ($body, $headers) = http_get $peer, "/", 2;
33             ...
34            
35             =head1 DESCRIPTION
36              
37             Making sure testing isn't a nightmare.
38              
39             This module provides some basic functions to find nginx-perl, prepare
40             configuration, generate handler, start in a child process, query it and
41             get something back. And it comes with Nginx::Perl. You can simply add it
42             as a dependency for you module and use.
43              
44             =cut
45              
46 16     16   810756 use strict;
  16         36  
  16         635  
47 16     16   82 use warnings;
  16         31  
  16         529  
48 16     16   82 no warnings 'uninitialized';
  16         39  
  16         617  
49 16     16   99 use bytes;
  16         23  
  16         103  
50              
51 16     16   398 use Config;
  16         29  
  16         617  
52 16     16   14054 use IO::Socket;
  16         519649  
  16         107  
53 16     16   11341 use File::Path qw(rmtree);
  16         102  
  16         148115  
54 143     143 0 1488 sub CRLF { "\x0d\x0a" }
55              
56              
57             =head1 EXPORT
58              
59             find_nginx_perl
60             get_nginx_conf_args_die
61             get_unused_port
62             wait_for_peer
63             prepare_nginx_dir_die
64             cat_nginx_logs
65             fork_nginx_die
66             fork_child_die
67             http_get
68             get_nginx_incs
69             fork_nginx_handler_die
70             eval_wait_sub
71             connect_peer
72             send_data
73             parse_http_request
74             parse_http_response
75             inject_content_length
76             read_http_response
77             make_path
78             cat_logs
79              
80             =cut
81              
82             require Exporter;
83             our @ISA = qw(Exporter);
84             our @EXPORT = qw(
85              
86             find_nginx_perl
87             get_nginx_conf_args_die
88             get_unused_port
89             wait_for_peer
90             prepare_nginx_dir_die
91             cat_nginx_logs
92             fork_nginx_die
93             fork_child_die
94             http_get
95             get_nginx_incs
96             fork_nginx_handler_die
97             eval_wait_sub
98             connect_peer
99             send_data
100             parse_http_request
101             parse_http_response
102             inject_content_length
103             read_http_response
104             make_path
105             cat_logs
106              
107             );
108              
109              
110             =head1 FUNCTIONS
111              
112             =head2 find_nginx_perl
113              
114             Finds executable binary for F. Returns executable path
115             or C if not found.
116              
117             my $nginx = find_nginx_perl
118             or die "Cannot find nginx-perl\n";
119            
120             # $nginx = './objs/nginx-perl'
121              
122             =cut
123              
124             sub find_nginx_perl () {
125              
126 16     16 1 1293328 foreach ( './objs/nginx-perl' ) {
127              
128 16 50 33     667 return $_
129             if -f $_ &&
130             -x $_;
131             }
132              
133              
134             # Assuming @INC contains .../Nginx-Perl-N.N.N.N/blib/lib
135             # it might have objs/nginx-perl there somewhere
136              
137 0         0 foreach my $inc ( @INC ) {
138              
139 0         0 local $_ = $inc;
140              
141 0         0 s!/+blib/+lib/*$!!;
142 0         0 s!/+blib/+arch/*$!!;
143              
144 0 0 0     0 if ( -f "$_/objs/nginx-perl" &&
145             -x "$_/objs/nginx-perl" ) {
146              
147 0         0 my $x = "$_/objs/nginx-perl";
148              
149 0 0       0 $x = "./$x" unless $x =~ m!^/|^\./!;
150              
151 0         0 return $x;
152             }
153             }
154              
155              
156 0         0 foreach ( "$Config{'scriptdir'}/nginx-perl",
157             "$Config{'sitescript'}/nginx-perl",
158             "$Config{'vendorscript'}/nginx-perl",
159             "$Config{'installscript'}/nginx-perl",
160             "$Config{'installsitescript'}/nginx-perl",
161             "$Config{'installvendorscript'}/nginx-perl",
162             '/usr/local/nginx-perl/sbin/nginx-perl' ) {
163              
164 0 0 0     0 return $_
165             if -f $_ &&
166             -x $_;
167             }
168              
169 0         0 return undef;
170             }
171              
172              
173             =head2 get_unused_port
174              
175             Returns available port number to bind to. Tries to use it first and returns
176             C if fails.
177              
178             $port = get_unused_port
179             or die "No unused ports\n";
180              
181             =cut
182              
183             sub get_unused_port () {
184 21     21 1 817 my $port = 50000 + int (rand() * 5000);
185              
186 21         95 while ($port++ < 64000) {
187 21 50       262 my $sock = IO::Socket::INET->new (
188             Listen => 5,
189             LocalAddr => '127.0.0.1',
190             LocalPort => $port,
191             Proto => 'tcp',
192             ReuseAddr => 1
193             ) or next;
194              
195 21         7362 $sock->close;
196 21         786 return $port;
197             }
198              
199 0         0 return undef;
200             }
201              
202              
203             =head2 wait_for_peer C<< "$host:$port", $timeout >>
204              
205             Tries to connect to C<$host:$port> within C<$timeout> seconds. Returns C<1>
206             on success and C on error.
207              
208             wait_for_peer "127.0.0.1:1234", 2
209             or die "Failed to connect to 127.0.0.1:1234 within 2 seconds";
210              
211             =cut
212              
213             sub wait_for_peer ($$) {
214 15     15 1 35742 my ($peer, $timeout) = @_;
215 15         48 my $rv;
216 15         112 my $at = time + $timeout;
217              
218 15         278 eval {
219 15     0   5768 local $SIG{'ALRM'} = sub { die "SIGALRM\n"; };
  0         0  
220              
221 15         367 for (my $t = time ; $at - $t > 0; $t = time) {
222 90         990 alarm $at - $t;
223              
224 90         3327 my $sock = IO::Socket::INET->new ( Proto => 'tcp',
225             PeerAddr => "$peer",
226             ReuseAddr => 1 );
227 90         197312 alarm 0;
228              
229 90 100       502 unless ($sock) {
230 75         7528868 select ('','','', 0.1);
231 75         1311 next;
232             }
233              
234 15         48 $rv = 1;
235 15         143 $sock->close;
236              
237 15         8925 last;
238             }
239             };
240              
241 15         102 alarm 0;
242 15         341 return $rv;
243             }
244              
245              
246             =head2 prepare_nginx_dir_die C<< $dir, $conf, @pkgs >>
247              
248             Creates directory tree suitable to run F from. Puts there
249             config and packages specified as string scalars. Dies on errors.
250              
251             prepare_nginx_dir_die "tmp/foo", <<'ENDCONF', <<'ENDONETWO';
252            
253             worker_processes 1;
254             events {
255             worker_connections 1024;
256             }
257             http {
258             server {
259             location / {
260             ...
261             }
262             }
263             }
264            
265             ENDCONF
266            
267             package One::Two;
268            
269             sub handler {
270             ...
271             }
272            
273             1;
274            
275             ENDONETWO
276              
277             =cut
278              
279             sub prepare_nginx_dir_die {
280 17     17 1 802 my ($dir, $conf, @pkgs) = @_;
281              
282 17         88 foreach ("$dir/html", "$dir/data") {
283 34 50       673 if (-e $_) {
284 34         25194 rmtree $_, 0, 0;
285             }
286             }
287              
288 17         128 foreach ("$dir",
289             "$dir/conf",
290             "$dir/lib",
291             "$dir/logs",
292             "$dir/html",
293             "$dir/data") {
294 102 100       1520 if (!-e $_) {
295 34 50       2569 mkdir $_
296             or die "Cannot create directory '$_': $!";
297             }
298             }
299              
300 17         88 foreach ( "$dir/lib",
301             "$dir/logs" ) {
302              
303 34 50       2152 open my $fh, '>', "$_/.exists"
304             or die "Cannot open file '$_/.exists' for writing: $!";
305 34         438 close $fh;
306             }
307              
308             {
309 17 50       49 open my $fh, '>', "$dir/html/index.html"
  17         1341  
310             or die "Cannot open file '$dir/html/index.html' for writing: $!";
311 17         64 binmode $fh;
312 17         276 print $fh "ok";
313 17         805 close $fh;
314             }
315              
316             {
317 17 50       41 opendir my $d, "$dir/logs"
  17         461  
318             or die "Cannot opendir '$dir/logs': $!";
319              
320 17 100 100     497 my @FILES = grep { $_ ne '.' && $_ ne '..' && $_ ne '.exists' &&
  119   100     2071  
321             -f "$dir/logs/$_" }
322             readdir $d;
323 17         206 closedir $d;
324              
325 17         68 foreach (@FILES) {
326 68         4145 unlink "$dir/logs/$_";
327             }
328             }
329              
330             {
331 17         41 my $incs = join "\n",
  238         581  
332 17         89 map { "perl_modules \"$_\";" }
333             get_nginx_incs (undef, $dir);
334             # injecting proper @INC
335 17         408 $conf =~ s/(\s+http\s*{)/$1\n$incs\n/gs;
336              
337             # injecting testing defaults
338 17 50       94 if ($conf !~ /events/) {
339 0         0 $conf = "events { worker_connections 128; }\n$conf";
340             }
341 17 50       89 if ($conf !~ /error_log/) {
342 0         0 $conf = "error_log logs/error.log debug;\n$conf";
343             }
344 17 50       89 if ($conf !~ /master_process/) {
345 0         0 $conf = "master_process off;\n$conf";
346             }
347 17 50       89 if ($conf !~ /daemon/) {
348 0         0 $conf = "daemon off;\n$conf";
349             }
350 17 50       92 if ($conf !~ /worker_processes/) {
351 0         0 $conf = "worker_processes 1;\n$conf";
352             }
353              
354 17 50       1426 open my $fh, '>', "$dir/conf/nginx-perl.conf"
355             or die "Cannot open file '$dir/conf/nginx-perl.conf' " .
356             "for writing: $!";
357              
358 17         246 print $fh $conf;
359              
360 17         795 close $fh;
361             }
362              
363 17         72 foreach (@pkgs) {
364              
365 13         107 my ($pkg) = / ^ \s* package \s+ ( [^\s]+ ) \; /sx;
366              
367 13         71 my @path = split '::', $pkg;
368 13         32 my $name = pop @path;
369 13         44 my $fullpath = "$dir/lib";
370              
371 13         121 foreach my $subdir (@path) {
372 0         0 $fullpath .= "/" . $subdir;
373              
374 0 0       0 mkdir $fullpath unless -e $fullpath;
375             }
376              
377 13 50       1027 open my $fh, '>', "$fullpath/$name.pm"
378             or die "Cannot open file '$fullpath/$name.pm' for writing: $!";
379              
380 13         182 print $fh $_;
381              
382 13         526 close $fh;
383             }
384             }
385              
386              
387             =head2 cat_nginx_logs C<< $dir >>
388              
389             Returns all logs from C<$dir.'/logs'> as a single scalar. Useful for
390             diagnostics.
391              
392             diag cat_nginx_logs $dir;
393              
394             =cut
395              
396             sub cat_nginx_logs ($) {
397 0     0 1 0 my ($dir) = @_;
398 0         0 my $out;
399              
400 0 0       0 opendir my $d, "$dir/logs"
401             or return undef;
402              
403 0 0 0     0 my @FILES = grep { $_ ne '.' && $_ ne '..' && $_ ne '.exists' &&
  0   0     0  
404             -f "$dir/logs/$_" }
405             readdir $d;
406 0         0 closedir $d;
407              
408 0         0 foreach (@FILES) {
409              
410 0         0 my $buf = do { open my $fh, '<', "$dir/logs/$_"; local $/; <$fh> };
  0         0  
  0         0  
  0         0  
411              
412 0         0 $out .= <<" EOF";
413              
414             $dir/logs/$_:
415             ------------------------------------------------------------------
416             $buf
417             ------------------------------------------------------------------
418              
419              
420             EOF
421             }
422              
423 0         0 return $out;
424             }
425              
426              
427             =head2 fork_nginx_die C<< $nginx, $dir >>
428              
429             Forks F using executable binary from C<$nginx> and
430             prepared directory path from C<$dir> and returns guard object.
431             Dies on errors. Internally does something like this: C<"$nginx -p $dir">
432              
433             my $child = fork_nginx_die $nginx, $dir;
434             ...
435            
436             undef $child;
437              
438             =cut
439              
440             {
441             package Nginx::Test::Child;
442              
443             sub new {
444 9     9   210 my $class = shift;
445 9         91 my $pid = shift;
446 9         178 my $self = \$pid;
447              
448 9         517 bless $self, $class;
449             }
450              
451             sub terminate {
452 9     9   25 my $self = shift;
453              
454 9 50       40 unless ($Nginx::Test::Child::IS_CHILD) {
455 9 50       112 if ($$self) {
456 9         7661 kill 'TERM', $$self; $$self = 0;
  9         40  
457 9         18420 wait;
458 9         904690 select '','','', 0.1;
459             }
460             }
461             }
462              
463 9     9   23095 sub DESTROY { my $self = shift; $self->terminate; }
  9         56  
464             }
465              
466             sub fork_nginx_die ($$) {
467 17     17 1 100 my ($nginx, $path) = @_;
468 17         19734 my $pid = fork();
469              
470 17 50       1808 die "failed to fork()"
471             if !defined $pid;
472              
473 17 100       1223 if ($pid == 0) {
474 8         716 $Nginx::Test::Child::IS_CHILD = 1;
475              
476 8 50       3489 open STDOUT, '>', "$path/logs/stdout.log"
477             or die "Cannot open file '$path/logs/stdout.log' for writing: $!";
478              
479 8 50       962 open STDERR, '>', "$path/logs/stderr.log"
480             or die "Cannot open file '$path/logs/stderr.log' for writing: $!";
481              
482 8 0       0 exec $nginx, '-p', $path
483             or die "exec '$nginx -p $path' failed\n";
484             }
485              
486 9         1434 return Nginx::Test::Child->new ($pid);
487             }
488              
489              
490             =head2 fork_child_die C<< sub {} >>
491              
492             Forks sub in a child process and returns its guard object. Dies on errors.
493              
494             my $child = fork_child_die sub {
495             ...
496             sleep 5;
497             };
498            
499             undef $child;
500              
501             =cut
502              
503             sub fork_child_die (&) {
504 0     0 1 0 my ($cb) = @_;
505 0         0 my $pid = fork();
506              
507 0 0       0 die "failed to fork()"
508             if !defined $pid;
509              
510 0 0       0 if ($pid == 0) {
511 0         0 $Nginx::Test::Child::IS_CHILD = 1;
512              
513 0         0 &$cb;
514 0         0 exit;
515             }
516              
517 0         0 return Nginx::Test::Child->new ($pid);
518             }
519              
520             =head2 get_nginx_conf_args_dir C<< $nginx >>
521              
522             Runs C, parses its output and returns a set of keys
523             out of the list of configure arguments.
524              
525             my %CONFARGS = get_nginx_conf_args_dir;
526            
527             # %CONFARGS = ( '--with-http_ssl_module' => 1,
528             # '--with-...' => 1 )
529              
530             =cut
531              
532             sub get_nginx_conf_args_die ($) {
533 1     1 0 33 my ($nginx) = @_;
534              
535 3         56 return map { $_ => 1 }
  5         26  
536 1         29 grep { /^--with/ }
537 3         40 map { split ' ', (split ':')[1] }
538             grep { /arguments/i }
539 1 50       2 do { open my $fh, '-|', "$nginx -V 2>&1"
  1         8997  
540             or die "Can't open '$nginx -V 2>&1 |': $!";
541 1         2570 <$fh> } ;
542             }
543              
544              
545             =head2 http_get C<< $peer, $uri, $timeout >>
546              
547             Connects to C<$peer>, sends GET request and return its C<$body> and
548             parsed C<$headers>.
549              
550             my ($body, $headers) = http_get '127.0.0.1:1234', '/', 2;
551            
552             $headers = { _status => 200,
553             _message => 'OK',
554             _version => 'HTTP/1.0',
555             'content-type' => ['text/html'],
556             'content-length' => [1234],
557             ... }
558              
559             =cut
560              
561             sub http_get ($$$) {
562 7     7 1 9078 my ($peer, $uri, $timeout) = @_;
563 7         26 my %h;
564 7         19 local $_;
565              
566 7         17 eval {
567 7     0   150 local $SIG{'ALRM'} = sub { die "timedout\n"; };
  0         0  
568              
569 7         50 alarm $timeout;
570              
571 7 50       95 my $sock = IO::Socket::INET->new ( Proto => 'tcp',
572             PeerAddr => $peer )
573             or die "$!\n";
574              
575 7         5516 print $sock "GET $uri HTTP/1.0" . CRLF .
576             "Host: $peer" . CRLF .
577             CRLF ;
578 7         63 local $/;
579 7         2013126 $_ = <$sock>;
580              
581 7         86 $sock->close;
582              
583              
584             # parsing HTTP response
585              
586 7         1922 @{h}{'_version', '_status', '_message'} =
587             m/ ^ \s* ( HTTP\/\d\.\d )
588             \s+ ( \d+ )
589             \s* ( [^\x0d\x0a]+ )
590             \x0d?\x0a /gcx;
591              
592 7         86 push @{$h{ lc($1) }}, $2
  43         473  
593             while
594             m/ \G \s* ( [a-zA-Z][\w-]+ )
595             \s* :
596             \s* ( [^\x0d\x0a]+ )
597             \x0d?\x0a /gcx;
598              
599 7         32 m/ \G \x0d?\x0a /gcx;
600              
601 7         209 $_ = substr $_, pos($_);
602              
603             };
604              
605 7         37 alarm 0;
606              
607 7 50       96 return wantarray ? $@ ? ()
    50          
608             : ($_, \%h)
609             : $_;
610             }
611              
612              
613             =head2 get_nginx_incs C<< $nginx, $dir >>
614              
615             Returns proper C<@INC> to use in F during tests.
616              
617             my @incs = get_nginx_incs $nginx, $dir;
618              
619             =cut
620              
621             sub get_nginx_incs ($$) {
622 17     17 1 47 my ($nginx, $path) = @_;
623 17         39 my $prefix = '';
624              
625 17 50       86 if ($path !~ m!^/!) {
626 17         90 $path =~ s!/+$!!;
627 17         248 $prefix = join '/', map { '..' } split /\/+/, $path;
  34         108  
628             }
629            
630 17 100       66 return ( 'lib', map { m!^/! ? $_ : "$prefix/$_" }
  221         801  
631             ('blib/lib', 'blib/arch', @INC) );
632             }
633              
634              
635             =head2 fork_nginx_handler_dir C<< $nginx, $dir, $conf, $code >>
636              
637             Gets unused port, prepares directory for nginx with predefined
638             package name, forks nginx and gives you a child object and generated
639             peer back. Allows to inject C<$conf> into F and
640             C<$code> into the package. Expects to found C
641             in C<$code>. Dies on errors.
642              
643             my ($child, $peer) =
644             fork_nginx_handler_die $nginx, $dir, <<'ENDCONF', <<'ENDCODE';
645            
646             resolver 8.8.8.8;
647            
648             ENDCONF
649              
650             sub handler {
651             my ($r) = @_;
652             ...
653            
654             return OK;
655             }
656            
657             ENDCODE
658             ...
659            
660             undef $child;
661              
662             Be aware that this function is not suited for every module. It expects
663             C<$dir> to be relative to the current directory or any of its subdirectories,
664             i.e. F, F. And also expects F and F
665             to contain your libraries, which is where L puts them.
666              
667             =cut
668              
669             sub fork_nginx_handler_die ($$$$) {
670 7     7 0 432 my ($nginx, $path, $conf, $code) = @_;
671              
672 7 50       32 my $port = get_unused_port
673             or die "Cannot get unused port";
674              
675 7         96 prepare_nginx_dir_die $path, <<" ENDCONF", <<" ENDPKG";
676              
677             worker_processes 1;
678             daemon off;
679             master_process off;
680              
681             error_log logs/error.log debug;
682              
683             events {
684             worker_connections 128;
685             }
686              
687             http {
688             default_type text/plain;
689              
690             perl_inc lib;
691             perl_inc ../lib;
692              
693             perl_require NginxPerlTest.pm;
694              
695             $conf
696              
697             server {
698             listen 127.0.0.1:$port;
699              
700             location / {
701             perl_handler NginxPerlTest::handler;
702             }
703             }
704             }
705              
706             ENDCONF
707              
708             package NginxPerlTest;
709              
710             use strict;
711             use warnings;
712             no warnings 'uninitialized';
713              
714             use Nginx;
715              
716             $code
717              
718             1;
719              
720             ENDPKG
721              
722 7         36 my $pid = fork_nginx_die $nginx, $path;
723 4         85 my $peer = "127.0.0.1:$port";
724              
725 4         195 return ($pid, $peer);
726             }
727              
728              
729             =head2 eval_wait_sub C<< $name, $timeout, $sub >>
730              
731             Wraps C block around subroutine C<$sub>, sets alarm to C<$timeout>
732             and waits for sub to finish. Returns undef on alarm and if C<$sub> dies.
733              
734             my $rv = eval_wait_sub "test1", 5, sub {
735             ...
736             pass "test1";
737             };
738            
739             fail "test1" unless $rv;
740              
741             =cut
742              
743             sub eval_wait_sub ($$) {
744 162     162 1 318 my $timeout = shift;
745 162         353 my $sub = shift;
746 162         185 my $rv;
747              
748 162         236 eval {
749 162     0   3352 local $SIG{ALRM} = sub { die "SIGALRM\n" };
  0         0  
750 162         959 alarm $timeout;
751              
752 162         334 $rv = &$sub;
753             };
754              
755 162         929 alarm 0;
756              
757 162 50       521 unless ($@) {
758 162         1144 return $rv;
759             } else {
760             # Test::More::diag "\neval_wait_sub ('$name', $timeout, ...) died: $@\n";
761 0         0 return undef;
762             }
763             }
764              
765              
766             =head2 connect_peer C<< "$host:$port", $timeout >>
767              
768             Tries to connect to C<$host:$port> within C<$timeout> seconds.
769             Returns socket handle on success or C otherwise.
770              
771             $sock = connect_peer "127.0.0.1:55555", 5
772             or ...;
773              
774             =cut
775              
776             sub connect_peer ($$) {
777 52     52 1 55770 my ($peer, $timeout) = @_;
778              
779             return eval_wait_sub $timeout, sub {
780 52 50   52   531 my $sock = IO::Socket::INET->new (PeerAddr => $peer)
781             or die "$!\n";
782              
783 52         34081 $sock->autoflush(1);
784              
785 52         3111 return $sock;
786 52         454 };
787             }
788              
789              
790             =head2 send_data C<< $sock, $buf, $timeout >>
791              
792             Sends an entire C<$buf> to the socket C<$sock> in C<$timeout> seconds.
793             Returns amount of data sent on success or undef otherwise. This amount
794             is guessed since C is used to send data.
795              
796             send_data $sock, $buf, 5
797             or ...;
798              
799             =cut
800              
801             sub send_data ($$$) {
802 55     55 1 1894 my ($sock, undef, $timeout) = @_;
803 55         148 my $buf = \$_[1];
804              
805             return eval_wait_sub $timeout, sub {
806 55     55   29064 print $sock $$buf;
807 55         1151 return length $$buf;
808 55         326 };
809             }
810              
811              
812             =head2 parse_http_request C<< $buf, $r >>
813              
814             Parses HTTP request from C<$buf> and puts parsed data structure into C<$r>.
815             Returns length of the header in bytes on success or C on error.
816             Returns C<0> if cannot find header separator C<"\n\n"> in C<$buf>.
817              
818             Data returned in the following form:
819              
820             $r = { 'connection' => ['close'],
821             'content-type' => ['text/html'],
822             ...
823             '_method' => 'GET',
824             '_request_uri' => '/?foo=bar',
825             '_version' => 'HTTP/1.0',
826             '_uri' => '/',
827             '_query_string' => 'foo=bar',
828             '_keepalive' => 0 };
829              
830             Example:
831              
832             $len = parse_http_request $buf, $r;
833            
834             if ($len) {
835             # ok
836             substr $buf, 0, $len, '';
837             warn Dumper $r;
838             } elsif (defined $len) {
839             # read more data
840             # and try again
841             } else {
842             # bad request
843             }
844              
845             =cut
846              
847             sub parse_http_request ($$) {
848 0     0 1 0 my $buf = \$_[0];
849              
850 0 0 0     0 if ($$buf =~ /(\x0d\x0a\x0d\x0a)/gs || $$buf =~ /(\x0a\x0a)/gs) {
851 0         0 my $header_len = pos($$buf) - length($1);
852 0         0 my $sep_len = length($1);
853              
854 0         0 pos($$buf) = 0; # just in case we want to reparse
855              
856 0         0 my @lines = split /^/, substr ($$buf, 0, $header_len);
857              
858             return undef
859 0 0       0 if @lines < 1;
860              
861 0         0 my %h;
862 0         0 @h{ '_method',
863             '_request_uri',
864             '_version' } = split ' ', shift @lines;
865              
866 0         0 @h{'_uri', '_query_string'} = split /\?/, $h{_request_uri}, 2;
867              
868 0         0 map {
869 0         0 my ($key, $value) = split ':', $_, 2;
870              
871 0         0 $key =~ s/^\s+//; $key =~ s/\s+$//;
  0         0  
872 0         0 $value =~ s/^\s+//; $value =~ s/\s+$//;
  0         0  
873              
874 0         0 push @{$h{ lc($key) }}, $value;
  0         0  
875             } @lines;
876              
877 0 0       0 if ($h{_version} eq 'HTTP/1.1') {
    0          
878 0 0       0 if (!exists $h{connection}) {
    0          
879 0         0 $h{_keepalive} = 1
880             } elsif ($h{connection}->[0] !~ /[Cc]lose/) {
881 0         0 $h{_keepalive} = 1
882             }
883             } elsif (exists $h{connection}) {
884 0 0       0 if ($h{connection}->[0] =~ /[Kk]eep-[Aa]live/) {
885 0         0 $h{_keepalive} = 1;
886             }
887             }
888              
889 0         0 $_[1] = \%h;
890 0         0 return $header_len + $sep_len;
891             } else {
892 0         0 return 0;
893             }
894             }
895              
896              
897             =head2 parse_http_response C<< $buf, $r >>
898              
899             Parses HTTP response from C<$buf> and puts parsed data structure into C<$r>.
900             Returns length of the header in bytes on success or C on error.
901             Returns C<0> if cannot find header separator C<"\n\n"> in C<$buf>.
902              
903             Data returned in the following form:
904              
905             $r = { 'connection' => ['close'],
906             'content-type' => ['text/html'],
907             ...
908             '_status' => '404',
909             '_message' => 'Not Found',
910             '_version' => 'HTTP/1.0',
911             '_keepalive' => 0 };
912              
913             Example:
914              
915             $len = parse_http_response $buf, $r;
916            
917             if ($len) {
918             # ok
919             substr $buf, 0, $len, '';
920             warn Dumper $r;
921             } elsif (defined $len) {
922             # read more data
923             # and try again
924             } else {
925             # bad response
926             }
927              
928             =cut
929              
930             sub parse_http_response ($$) {
931 103     103 1 775 my $buf = \$_[0];
932              
933 103 50 33     1596 if ($$buf =~ /(\x0d\x0a\x0d\x0a)/gs || $$buf =~ /(\x0a\x0a)/gs) {
934 103         468 my $header_len = pos($$buf) - length($1);
935 103         174 my $sep_len = length($1);
936              
937 103         322 pos($$buf) = 0;
938              
939 103         934 my @lines = split /^/, substr ($$buf, 0, $header_len);
940              
941             return undef
942 103 50       357 if @lines < 1;
943              
944 103         168 my %h;
945 103         648 @h{ '_version',
946             '_status',
947             '_message' } = split ' ', shift (@lines), 3;
948              
949 103         782 $h{_message} =~ s/\s+$//;
950              
951 405         1394 map {
952 103         246 my ($key, $value) = split ':', $_, 2;
953              
954 405         1811 $key =~ s/^\s+//; $key =~ s/\s+$//;
  405         655  
955 405         1407 $value =~ s/^\s+//; $value =~ s/\s+$//;
  405         1380  
956              
957 405         493 push @{$h{ lc($key) }}, $value;
  405         2246  
958             } @lines;
959              
960 103 50       324 if ($h{_version} eq 'HTTP/1.1') {
    0          
961 103 100       862 if (!exists $h{connection}) {
    100          
962 3         6 $h{_keepalive} = 1
963             } elsif ($h{connection}->[0] !~ /[Cc]lose/) {
964 3         12 $h{_keepalive} = 1
965             }
966             } elsif (exists $h{connection}) {
967 0 0       0 if ($h{connection}->[0] =~ /[Kk]eep-[Aa]live/) {
968 0         0 $h{_keepalive} = 1;
969             }
970             }
971              
972 103         190 $_[1] = \%h;
973 103         524 return $header_len + $sep_len;
974             } else {
975 0         0 return 0;
976             }
977             }
978              
979              
980             =head2 inject_content_length C<< $buf >>
981              
982             Parses HTTP header and inserts B if needed, assuming
983             that C<$buf> contains entire request or response.
984              
985             $buf = "PUT /" ."\x0d\x0a".
986             "Host: foo.bar" ."\x0d\x0a".
987             "" ."\x0d\x0a".
988             "hello";
989            
990             inject_content_length $buf;
991              
992             =cut
993              
994             sub inject_content_length ($) {
995 34     34 1 16250 my $buf = \$_[0];
996              
997 34 50       386 if ($$buf =~ /(\x0d\x0a\x0d\x0a)/gs) {
998 34         105 my $header_len = pos($$buf) - length($1);
999 34         96 pos($$buf) = 0;
1000 34         84 my $sep_len = length($1);
1001 34         183 my @lines = split /^/, substr ($$buf, 0, $header_len);
1002 34         55 shift @lines;
1003              
1004 34         62 my %h;
1005 57         168 map {
1006 34         64 my ($key, $value) = split ':', $_, 2;
1007              
1008 57         159 $key =~ s/^\s+//; $key =~ s/\s+$//;
  57         111  
1009 57         185 $value =~ s/^\s+//; $value =~ s/\s+$//;
  57         149  
1010              
1011 57         66 push @{$h{ lc($key) }}, $value;
  57         348  
1012             } @lines;
1013              
1014 34 100       462 if (length ($$buf) - $header_len - $sep_len > 0) {
1015 6 50       21 if (!exists $h{'content-length'}) {
1016 6         14 my $len = (length ($$buf) - $header_len - $sep_len);
1017 6         24 substr $$buf, $header_len + length (CRLF), 0,
1018             "Content-Length: $len" .CRLF;
1019 6         33 return $len;
1020             } else {
1021 0         0 return 0;
1022             }
1023             } else {
1024 28         123 return 0;
1025             }
1026             } else {
1027 0         0 return undef;
1028             }
1029             }
1030              
1031              
1032             =head2 read_http_response C<< $sock, $h, $timeout >>
1033              
1034             Reads and parses HTTP response header from C<$sock> into C<$h>
1035             within C<$timeout> seconds.
1036             Returns true on success or C on error.
1037              
1038             read_http_response $sock, $h, 5
1039             or ...;
1040              
1041             =cut
1042              
1043             sub read_http_response ($$$$) {
1044 55     55 1 811 my ($sock, undef, undef, $timeout) = @_;
1045 55         178 my $buf = \$_[1];
1046 55         178 my $h = \$_[2];
1047              
1048             return eval_wait_sub $timeout, sub {
1049 55     55   258 local $/ = CRLF.CRLF;
1050 55         2027686 $$buf = <$sock>;
1051              
1052 55 50       307 parse_http_response $$buf, $$h
1053             or return undef;
1054              
1055 55         133 $$buf = '';
1056 55 50       438 my $len = $$h->{'content-length'} ? $$h->{'content-length'}->[0] : 0;
1057              
1058 55 100       158 if ($len) {
1059 52         537 local $/ = \$len;
1060 52         793 $$buf = <$sock>;
1061             }
1062              
1063 55         1121 return 1;
1064 55         475 };
1065             }
1066              
1067              
1068             =head2 make_path C<< $path >>
1069              
1070             Creates directory tree specified by C<$path> and returns this path
1071             or undef on error.
1072              
1073             $path = make_path 'tmp/foo'
1074             or die "Can't create tmp/foo: $!\n";
1075              
1076             =cut
1077              
1078             sub make_path ($) {
1079 10     10 1 1497108 my $path = shift;
1080 10         88 my @dirs = split /[\/\\]+/, $path;
1081 10         20 my $dir;
1082              
1083 10 50 33     104 pop @dirs if @dirs && $dirs[-1] eq '';
1084              
1085 10         26 foreach (@dirs) {
1086 20         32 $dir .= "$_";
1087              
1088 20 50       62 if ($dir) {
1089 20 50       290 if (!-e $dir) {
1090 0 0       0 mkdir $dir
1091             or return undef;
1092             }
1093             }
1094              
1095 20         48 $dir .= '/';
1096             }
1097              
1098 10         44 return $path;
1099             }
1100              
1101              
1102             =head2 cat_logs C<< $dir >>
1103              
1104             Scans directory C<$dir> for logs, concatenates them and returns.
1105              
1106             diag cat_logs $dir;
1107              
1108             =cut
1109              
1110             sub cat_logs ($) {
1111 0     0 1   my ($dir) = @_;
1112 0           my $out;
1113              
1114 0 0         opendir my $d, $dir
1115             or return undef;
1116              
1117 0 0 0       my @FILES = grep { ($_ ne '.' && $_ ne '..' && $_ ne '.exists') &&
  0   0        
1118             -f "$dir/$_" }
1119             readdir $d;
1120 0           closedir $d;
1121              
1122 0           foreach (@FILES) {
1123              
1124 0           my $buf = do { open my $fh, '<', "$dir/$_"; local $/; <$fh> };
  0            
  0            
  0            
1125              
1126 0           $out .= <<" EOF";
1127              
1128             $dir/$_:
1129             ------------------------------------------------------------------
1130             $buf
1131             ------------------------------------------------------------------
1132              
1133              
1134             EOF
1135             }
1136              
1137 0           return $out;
1138             }
1139              
1140              
1141             =head1 AUTHOR
1142              
1143             Alexandr Gomoliako
1144              
1145             =head1 LICENSE
1146              
1147             Copyright 2011-2012 Alexandr Gomoliako. All rights reserved.
1148              
1149             This module is free software. It may be used, redistributed and/or modified
1150             under the same terms as B itself.
1151              
1152             =cut
1153              
1154             1;