[BACK]Return to LightyTest.pm CVS log [TXT] [DIR] Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / lighttpd / tests

Diff for /embedaddon/lighttpd/tests/LightyTest.pm between versions 1.1.1.1 and 1.1.1.2

version 1.1.1.1, 2013/10/14 10:32:47 version 1.1.1.2, 2016/11/02 10:35:00
Line 1 Line 1
 #! /usr/bin/perl -w  
   
 package LightyTest;  package LightyTest;
   
 use strict;  use strict;
 use IO::Socket;  use IO::Socket;
 use Test::More;  use Test::More;
Line 9  use Cwd 'abs_path'; Line 8  use Cwd 'abs_path';
 use POSIX qw(:sys_wait_h dup2);  use POSIX qw(:sys_wait_h dup2);
 use Errno qw(EADDRINUSE);  use Errno qw(EADDRINUSE);
   
   sub find_program {
           my @DEFAULT_PATHS = ('/usr/bin/', '/usr/local/bin/');
           my ($envname, $program) = @_;
           my $location;
   
           if (defined $ENV{$envname}) {
                   $location = $ENV{$envname};
           } else {
                   $location = `which "$program" 2>/dev/null`;
                   chomp $location;
                   if (! -x $location) {
                           for my $path (@DEFAULT_PATHS) {
                                   $location = $path . $program;
                                   last if -x $location;
                           }
                   }
           }
   
           if (-x $location) {
                   $ENV{$envname} = $location;
                   return 1;
           } else {
                   delete $ENV{$envname};
                   return 0;
           }
   }
   
   BEGIN {
           our $HAVE_PHP = find_program('PHP', 'php-cgi');
           our $HAVE_PERL = find_program('PERL', 'perl');
           if (!$HAVE_PERL) {
                   die "Couldn't find path to perl, but it obviously seems to be running";
           }
   }
   
 sub mtime {  sub mtime {
         my $file = shift;          my $file = shift;
         my @stat = stat $file;          my @stat = stat $file;
         return @stat ? $stat[9] : 0;          return @stat ? $stat[9] : 0;
 }  }
   
 sub new {  sub new {
         my $class = shift;          my $class = shift;
         my $self = {};          my $self = {};
Line 58  sub listening_on { Line 93  sub listening_on {
         my $self = shift;          my $self = shift;
         my $port = shift;          my $port = shift;
   
        my $remote =         my $remote = IO::Socket::INET->new(
          IO::Socket::INET->new(Proto    => "tcp",                Proto    => "tcp",
                                PeerAddr => "127.0.0.1",                PeerAddr => "127.0.0.1",
                                PeerPort => $port) or return 0;                PeerPort => $port) or return 0;
   
         close $remote;          close $remote;
   
Line 87  sub wait_for_port_with_proc { Line 122  sub wait_for_port_with_proc {
         my $self = shift;          my $self = shift;
         my $port = shift;          my $port = shift;
         my $child = shift;          my $child = shift;
        my $timeout = 5*10; # 5 secs, select waits 0.1 s        my $timeout = 10*10; # 10 secs (valgrind might take a while), select waits 0.1 s
   
         while (0 == $self->listening_on($port)) {          while (0 == $self->listening_on($port)) {
                 select(undef, undef, undef, 0.1);                  select(undef, undef, undef, 0.1);
Line 125  sub start_proc { Line 160  sub start_proc {
   
         my @cmdline = ($self->{LIGHTTPD_PATH}, "-D", "-f", $self->{SRCDIR}."/".$self->{CONFIGFILE}, "-m", $self->{MODULES_PATH});          my @cmdline = ($self->{LIGHTTPD_PATH}, "-D", "-f", $self->{SRCDIR}."/".$self->{CONFIGFILE}, "-m", $self->{MODULES_PATH});
         if (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'strace') {          if (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'strace') {
                @cmdline = (qw(strace -tt -s 512 -o strace), @cmdline);                @cmdline = (qw(strace -tt -s 4096 -o strace -f -v), @cmdline);
         } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'truss') {          } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'truss') {
                 @cmdline = (qw(truss -a -l -w all -v all -o strace), @cmdline);                  @cmdline = (qw(truss -a -l -w all -v all -o strace), @cmdline);
         } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'gdb') {          } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'gdb') {
                 @cmdline = ('gdb', '--batch', '--ex', 'run', '--ex', 'bt full', '--args', @cmdline);                  @cmdline = ('gdb', '--batch', '--ex', 'run', '--ex', 'bt full', '--args', @cmdline);
         } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'valgrind') {          } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'valgrind') {
                @cmdline = (qw(valgrind --tool=memcheck --show-reachable=yes --leak-check=yes --log-file=valgrind), @cmdline);                @cmdline = (qw(valgrind --tool=memcheck --track-origins=yes --show-reachable=yes --leak-check=yes --log-file=valgrind.%p), @cmdline);
         }          }
         # diag("\nstarting lighttpd at :".$self->{PORT}.", cmdline: ".@cmdline );          # diag("\nstarting lighttpd at :".$self->{PORT}.", cmdline: ".@cmdline );
         my $child = fork();          my $child = fork();
Line 165  sub handle_http { Line 200  sub handle_http {
         my $slow = defined $t->{SLOWREQUEST};          my $slow = defined $t->{SLOWREQUEST};
         my $is_debug = $ENV{"TRACE_HTTP"};          my $is_debug = $ENV{"TRACE_HTTP"};
   
        my $remote =         my $remote =
          IO::Socket::INET->new(Proto    => "tcp",                IO::Socket::INET->new(
                                PeerAddr => $host,                        Proto    => "tcp",
                                PeerPort => $self->{PORT});                        PeerAddr => $host,
                         PeerPort => $self->{PORT});
   
         if (not defined $remote) {          if (not defined $remote) {
                 diag("\nconnect failed: $!");                  diag("\nconnect failed: $!");
                return -1;                return -1;
         }          }
   
         $remote->autoflush(1);          $remote->autoflush(1);
Line 187  sub handle_http { Line 223  sub handle_http {
                         print $remote $_.$BLANK;                          print $remote $_.$BLANK;
                         diag("\n<< ".$_) if $is_debug;                          diag("\n<< ".$_) if $is_debug;
                 }                  }
                 shutdown($remote, 1); # I've stopped writing data  
         } else {          } else {
                 diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug;                  diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug;
                 foreach(@request) {                  foreach(@request) {
Line 208  sub handle_http { Line 243  sub handle_http {
                         print $remote "\012";                          print $remote "\012";
                         select(undef, undef, undef, 0.1);                          select(undef, undef, undef, 0.1);
                 }                  }
        
         }          }
         diag("\n... done") if $is_debug;          diag("\n... done") if $is_debug;
   
Line 221  sub handle_http { Line 256  sub handle_http {
                 diag(">> ".$_) if $is_debug;                  diag(">> ".$_) if $is_debug;
         }          }
         diag("\n... done") if $is_debug;          diag("\n... done") if $is_debug;
        
         close $remote;          close $remote;
   
         my $full_response = $lines;          my $full_response = $lines;
Line 250  sub handle_http { Line 285  sub handle_http {
                                         (my $h = $1) =~ tr/[A-Z]/[a-z]/;                                          (my $h = $1) =~ tr/[A-Z]/[a-z]/;
   
                                         if (defined $resp_hdr{$h}) {                                          if (defined $resp_hdr{$h}) {
#                                               diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n",#                                                diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n",
#                                                            $h, $resp_hdr{$h}, $2));#                                                            $h, $resp_hdr{$h}, $2));
                                                 $resp_hdr{$h} .= ', '.$2;                                                  $resp_hdr{$h} .= ', '.$2;
                                         } else {                                          } else {
                                                 $resp_hdr{$h} = $2;                                                  $resp_hdr{$h} = $2;
Line 307  sub handle_http { Line 342  sub handle_http {
                                 return -1;                                  return -1;
                         }                          }
                 }                  }
                
                 if (defined $href->{'-HTTP-Content'}) {                  if (defined $href->{'-HTTP-Content'}) {
                         if (defined $resp_body && $resp_body ne '') {                          if (defined $resp_body && $resp_body ne '') {
                                 diag(sprintf("\nbody failed: expected empty body, got '%s'", $resp_body));                                  diag(sprintf("\nbody failed: expected empty body, got '%s'", $resp_body));
Line 334  sub handle_http { Line 369  sub handle_http {
                                 $k = substr($k, 1);                                  $k = substr($k, 1);
                                 $key_inverted = 1;                                  $key_inverted = 1;
                                 $verify_value = 0; ## skip the value check                                  $verify_value = 0; ## skip the value check
                        }                        }
   
                         if ($key_inverted) {                          if ($key_inverted) {
                                 if (defined $resp_hdr{$k}) {                                  if (defined $resp_hdr{$k}) {
Line 351  sub handle_http { Line 386  sub handle_http {
                         if ($verify_value) {                          if ($verify_value) {
                                 if ($href->{$_} =~ /^\/(.+)\/$/) {                                  if ($href->{$_} =~ /^\/(.+)\/$/) {
                                         if ($resp_hdr{$k} !~ /$1/) {                                          if ($resp_hdr{$k} !~ /$1/) {
                                                diag(sprintf("\nresponse-header failed: expected '%s', got '%s', regex: %s",                                                 diag(sprintf(
                                                     $href->{$_}, $resp_hdr{$k}, $1));                                                        "\nresponse-header failed: expected '%s', got '%s', regex: %s",
                                                         $href->{$_}, $resp_hdr{$k}, $1));
                                                 return -1;                                                  return -1;
                                         }                                          }
                                 } elsif ($href->{$_} ne $resp_hdr{$k}) {                                  } elsif ($href->{$_} ne $resp_hdr{$k}) {
                                        diag(sprintf("\nresponse-header failed: expected '%s', got '%s'",                                        diag(sprintf(
                                             $href->{$_}, $resp_hdr{$k}));                                                "\nresponse-header failed: expected '%s', got '%s'",
                                                 $href->{$_}, $resp_hdr{$k}));
                                         return -1;                                          return -1;
                                 }                                  }
                         }                          }
Removed from v.1.1.1.1  
changed lines
  Added in v.1.1.1.2

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>