add basic script test
authorJens Rehsack <sno@NetBSD.org>
Mon, 13 Aug 2012 15:19:28 +0000 (13 17:19 +0200)
committerJens Rehsack <sno@NetBSD.org>
Mon, 13 Aug 2012 15:19:28 +0000 (13 17:19 +0200)
t/10-live.t [new file with mode: 0644]
t/mock-daemon.pl [new file with mode: 0644]
t/talk-to-ourself.pl [new file with mode: 0644]

diff --git a/t/10-live.t b/t/10-live.t
new file mode 100644 (file)
index 0000000..752c3cf
--- /dev/null
@@ -0,0 +1,171 @@
+#! perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+use File::Basename;
+use IO::CaptureOutput qw(capture);
+
+# check whether we can talk to ourself or not ...
+# ...
+
+delete $ENV{PERL_LWP_ENV_PROXY};
+
+use Config;
+my $perl = $Config{'perlpath'};
+$perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
+
+my $loc = dirname($0);
+
+$| = 1;    # autoflush
+
+# First we ensure that we can talk to ourself ...
+
+system( $perl, File::Spec->catfile( $loc, "talk-to-ourself.pl" ) );
+my $status = $?;
+$status and BAIL_OUT("Can't talk to ourself");
+
+require IO::Socket;         # make sure this work before we try to make a HTTP::Daemon
+use POSIX ":sys_wait_h";    # for nonblocking read
+
+# Seconds we make a daemon in another process
+
+my ( $daemon_pipe, $daemon_pid );
+local $SIG{CHLD} = sub {
+    local ( $!, $? );
+    my $pid = waitpid( -1, WNOHANG );
+    $pid == $daemon_pid or return;
+    $daemon_pid = undef;
+    close($daemon_pipe);
+    $daemon_pipe = undef;
+};
+
+$daemon_pid = open( $daemon_pipe,
+           "$perl " . File::Spec->catfile( $loc, "mock-daemon.pl" ) . " --httpd-opts Timeout=10  --httpd-opts hdf=1 |" )
+  or die "Can't exec daemon: $!";
+
+END { $daemon_pid and kill( $daemon_pid => 0 ); $daemon_pipe and close($daemon_pipe); }
+
+my $greeting = <$daemon_pipe>;
+$greeting =~ /(<[^>]+>)/;
+
+require URI;
+my $base = URI->new($1);
+
+sub url
+{
+    my $u = URI->new(@_);
+    $u = $u->abs( $_[1] ) if @_ > 1;
+    $u->as_string;
+}
+
+note "Will access HTTP server at $base\n";
+
+use WWW::Mechanize::Script;
+
+my %cfg = (
+     "defaults" => {
+                     "check" => {
+                                  "code_cmp"              => ">",
+                                  "response_code"         => 2,
+                                  "min_bytes_code"        => 2,
+                                  "max_bytes_code"        => 1,
+                                  "regex_forbid_code"     => 2,
+                                  "regex_require_code"    => 2,
+                                  "text_forbid_code"      => 2,
+                                  "text_require_code"     => 2,
+                                  "min_elapsed_time_code" => 1,
+                                  "max_elapsed_time_code" => 2,
+                                },
+                     "request" => { "method" => "GET" }
+                   },
+     "templating" => {
+         "vars" =>
+           { "CODE_NAMES" => [ "OK", "WARNING", "CRITICAL", "UNKNOWN", "DEPENDENT", "EXCEPTION" ] },
+     },
+     "summary" => {
+                "template" =>
+                  "[% CODE_NAMES.\$CODE; IF MESSAGES.size > 0 %] - [% MESSAGES.join(', '); END %]\n",
+                "target" => "-"
+     },
+     "report" => {
+                   "template" => "[% USE Dumper; Dumper.dump(RESPONSE) %]",
+                   "target"   => "-"
+                 }
+          );
+my @script = (
+    {
+       "request" => {
+                      "method" => "get",
+                      "uri"    => url("/etc/passwd", $base),
+                    },
+       "check" => {
+                    "test_name"    => "passwd1",
+                    "text_require" => [ "/root", "daemon", ":bin:" ],
+                    "text_forbid"  => [ "staff", ],
+                  },
+    },
+    {
+       "request" => {
+                      "method" => "get",
+                      "uri"    => url("/etc/passwd", $base),
+                    },
+       "check" => {
+                    "test_name" => "passwd2",
+                    "min_rtime" => "0.01",
+                    "max_rtime" => "1",
+                  },
+    },
+    {
+       "request" => {
+                      "method" => "get",
+                      "uri"    => url("/etc/passwd", $base),
+                    },
+       "check" => {
+                    "test_name" => "passwd3",
+                    "min_bytes" => "1",
+                    "max_bytes" => "65536",
+                  },
+    },
+    {
+       "request" => {
+                      "method" => "get",
+                      "uri"    => url("/etc/passwd", $base),
+                    },
+       "check" => {
+           "test_name"     => "passwd4",
+           "regex_require" => [
+                                "(?:\\:\\d){2}",    # uid/gid
+                                "(?:/\\w+){2}",     # shell ;)
+                              ],
+           "regex_forbid" => [ "^\\w+:\\w{2,}", ],  # password
+                  },
+    },
+    {
+       "request" => {
+                      "method" => "get",
+                      "uri"    => url("/etc/master.passwd", $base),
+                    },
+       "check" => {
+           "test_name"     => "exit_status",
+          "response" => 418,
+       },
+    }
+             );
+
+my $wms = WWW::Mechanize::Script->new( \%cfg );
+
+isa_ok($wms, "WWW::Mechanize::Script") or BAIL_OUT("Need WWW::Mechanize::Script");
+
+my ( $code, @msgs ) = (0);
+my ( $stdout, $stderr );
+#capture {
+eval { ( $code, @msgs ) = $wms->run_script(@script); };
+#} \$stdout, \$stderr;
+
+cmp_ok($code, '==', 0, "Test script runs without error");
+is_deeply( \@msgs, [], "No messages" );
+
+done_testing();
diff --git a/t/mock-daemon.pl b/t/mock-daemon.pl
new file mode 100644 (file)
index 0000000..cb77875
--- /dev/null
@@ -0,0 +1,118 @@
+#!perl
+
+use strict;
+use warnings;
+
+package HTTP::Daemon::MockClient;
+
+use HTTP::Daemon;
+use base qw(HTTP::Daemon::ClientConn);
+
+use HTTP::Status qw(:constants);
+use Params::Util qw(_ARRAY _STRING);
+
+my %documents = (
+    "/etc/passwd" => [
+                       "root:x:0:0:root:/root:/bin/sh", "daemon:x:1:1:daemon:/usr/sbin:/bin/sh",
+                       "bin:x:2:2:bin:/bin:/bin/sh"
+                     ],
+    "/etc/fstab" => [
+                      "# <file system> <mount point>   <type>  <options>       <dump>  <pass>",
+                      "proc            /proc           proc    nodev,noexec,nosuid 0       0",
+                      "/dev/sda1       /               ext2    defaults        0       0",
+                      "/dev/sdb1       /data           ext2    defaults        0       0",
+                      "none            /tmp            tmpfs   defaults,noatime        0       0",
+                    ],
+    "/etc/master.passwd"  => "/etc/master.passwd",
+    "/var/run/dmesg.boot" => [
+        '[    0.000000] Initializing cgroup subsys cpuset',
+        '[    0.000000] Initializing cgroup subsys cpu',
+        '[    0.000000] Linux version 2.6.32-41-generic (buildd@allspice) (gcc version 4.4.3 (Ubuntu 4.4.3-4ubuntu5.1) ) #94-Ubuntu SMP Fri Jul 6 18:00:34 UTC 2012 (Ubuntu 2.6.32-41.94-generic 2.6.32.59+drm33.24)'
+    ],
+    "/var/log/messages" => "/var/run/dmesg.boot",
+);
+
+sub respond_text_content
+{
+    my ( $c, @cnt ) = @_;
+    my $resp = HTTP::Response->new(HTTP_OK);
+    $resp->header( "Content-Type", "text/plain" );
+    $resp->content( join( "\n", @cnt ) );
+    $c->send_response($resp);
+}
+
+sub handle_httpd_get
+{
+    my ( $c, $req ) = @_;
+    my $p = $req->uri()->path();
+    if ( exists( $documents{$p} ) )
+    {
+        if ( _ARRAY( $documents{$p} ) )
+        {
+            $c->respond_text_content( @{ $documents{$p} } );
+        }
+        elsif ( _STRING( $documents{$p} ) )
+        {
+            my $tgt = $documents{$p};
+            if ( $p eq $tgt )
+            {
+                $c->send_error(HTTP_I_AM_A_TEAPOT);
+                $c->send_crlf;
+                return 0 - HTTP_I_AM_A_TEAPOT;
+            }
+            else
+            {
+                $c->send_redirect( $tgt, HTTP_TEMPORARY_REDIRECT );
+                $c->send_crlf;
+            }
+        }
+        else
+        {
+            $c->send_error(HTTP_FORBIDDEN);
+            $c->send_crlf;
+        }
+    }
+    else
+    {
+        $c->send_error(HTTP_NOT_FOUND);
+        $c->send_crlf;
+    }
+
+    return 0;
+}
+
+package main;
+
+use Getopt::Long;
+
+use HTTP::Daemon;
+use HTTP::Status qw(:constants);
+
+my %opts = ();
+GetOptions( "httpd-opts=s%" => \%opts );
+
+my $d = HTTP::Daemon->new(%opts);
+
+print "Please to meet you at: <URL:", $d->url, ">\n";
+open( STDOUT, $^O eq 'VMS' ? ">nl: " : ">/dev/null" );
+
+my $go = 1;
+while ( $go and my $c = $d->accept("HTTP::Daemon::MockClient") )
+{
+    while ( my $r = $c->get_request )
+    {
+        my $func = lc( "handle_httpd_" . $r->method );
+        if ( $c->can($func) )
+        {
+            0 == $c->$func($r) or $go = 0;
+        }
+        else
+        {
+            $c->send_error(HTTP_METHOD_NOT_ALLOWED);
+        }
+    }
+    $c = undef;    # close connection
+}
+$opts{hdf} or print STDERR "HTTP Server terminated\n";
+exit;
+
diff --git a/t/talk-to-ourself.pl b/t/talk-to-ourself.pl
new file mode 100644 (file)
index 0000000..dbb0e4c
--- /dev/null
@@ -0,0 +1,61 @@
+#!perl -w
+
+# This program check if we are able to talk to ourself.  Misconfigured
+# systems that can't talk to their own 'hostname' was the most commonly
+# reported libwww-failure.
+
+use strict;
+require IO::Socket;
+
+if ( @ARGV >= 2 && $ARGV[0] eq "--port" )
+{
+    my $port = $ARGV[1];
+    require Sys::Hostname;
+    my $host = Sys::Hostname::hostname();
+    if (
+         my $socket = IO::Socket::INET->new( PeerAddr => "$host:$port",
+                                             Timeout  => 5 )
+       )
+    {
+        require IO::Select;
+        if ( IO::Select->new($socket)->can_read(1) )
+        {
+            my ( $n, $buf );
+            if ( $n = sysread( $socket, $buf, 512 ) )
+            {
+                exit if $buf eq "Hi there!\n";
+                die "Seems to be talking to the wrong server at $host:$port, got \"$buf\"\n";
+            }
+            elsif ( defined $n )
+            {
+                die "Immediate EOF from server at $host:$port\n";
+            }
+            else
+            {
+                die "Can't read from server at $host:$port: $!";
+            }
+        }
+        die "No response from server at $host:$port\n";
+    }
+    die "Can't connect: $@\n";
+}
+
+# server code
+my $socket = IO::Socket::INET->new( Listen  => 1,
+                                    Timeout => 5 );
+my $port = $socket->sockport;
+open( CLIENT, qq("$^X" "$0" --port $port |) ) || die "Can't run $^X $0: $!\n";
+
+if ( my $client = $socket->accept )
+{
+    print $client "Hi there!\n";
+    close($client) || die "Can't close socket: $!";
+}
+else
+{
+    warn "Test server timeout\n";
+}
+
+exit if close(CLIENT);
+die "Can't wait for client: $!" if $!;
+die "The can-we-talk-to-ourself test failed.\n";