diff options
Diffstat (limited to 't')
| -rw-r--r-- | t/httpd-unit.t | 116 | ||||
| -rw-r--r-- | t/httpd.t | 42 | ||||
| -rw-r--r-- | t/mwrap.t | 177 | ||||
| -rw-r--r-- | t/source_location.perl | 9 | ||||
| -rw-r--r-- | t/test_common.perl | 20 |
5 files changed, 45 insertions, 319 deletions
diff --git a/t/httpd-unit.t b/t/httpd-unit.t deleted file mode 100644 index e16be1d..0000000 --- a/t/httpd-unit.t +++ /dev/null @@ -1,116 +0,0 @@ -#!perl -w -# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -use v5.12; -use autodie; -use Test::More; -use ExtUtils::CBuilder; -use File::Spec; -use File::Temp; -use File::Path; -my ($n) = (__FILE__ =~ m!/([^/]+)\.t\z!); -open my $fh, '<', 'build.env'; -my %build_env = map { chomp; ( split(/=/, $_, 2) ) } (<$fh>); -my $tmp = File::Temp->newdir("$n-XXXX"); -my $err = "$tmp/err.log"; -open my $olderr, '+>&', *STDERR{IO}; -my $end_err = sub { - STDERR->autoflush(1); - open STDERR, '+>&', $olderr; - open my $eh, '+<', $err; - local $/; - my $buf = <$eh> // BAIL_OUT "$!"; - truncate($eh, 0); - diag "err=$buf" if $ENV{V}; - $buf; -}; - -my @vg = split(/ /, $ENV{VALGRIND} // ''); - -# using predictable pathnames but outside of working directory. -# This gives ccache-friendliness while staying clear of MakeMaker -# aggressively trying to include every *.c file -my $d = File::Spec->tmpdir . "/$>.mwrap-test"; -if (!-d $d) { - diag "# mkdir $d"; - mkdir($d, 0700); -} -my $f = "$d/$n.c"; -open $fh, '>', $f; -print $fh <<C; -#include <sys/types.h> -#include <unistd.h> -#define getpid() my_getpid() -static pid_t my_getpid(void) -{ - return TEST_PID; -} -#include "mwrap_core.h" - -int main(int argc, const char *argv[]) -{ - struct mw_h1d h1d; - return h1d_init(&h1d, argv[1]); -} -C -close $fh; -my $TEST_PID = 10; -my $cb = ExtUtils::CBuilder->new(quiet => $ENV{V} ? 0 : 1); -my ($obj, $exe); -{ - my %be = %build_env; - $be{extra_compiler_flags} .= " -DTEST_PID=$TEST_PID -Wall "; - $obj = $cb->compile(source => $f, %be); - $exe = $cb->link_executable(exe_file => "$d/$n", objects => $obj, %be); -} -open STDERR, '>', $err; -is(system(@vg, $exe, "socket_dir:$d"), 0, "$exe"); -is($end_err->(), '', 'silence is golden'); - -my $s = "$d/$TEST_PID.sock"; -ok(-S $s, 'sock created'); -unlink($s); - -mkdir($s); -open STDERR, '>', $err; -isnt(system(@vg, $exe, "socket_dir:$d"), 0, "won't clobber dir"); -like($end_err->(), qr/unlink/, 'unlink fails for dir'); -rmdir($s); - -open STDERR, '>', $err; -is(system(@vg, $exe, "socket_dir:$d/"), 0, "listen again"); -is($end_err->(), '', 'silence is golden'); - -{ - my $t_mkdir = "$d/mkdir"; - File::Path::rmtree($t_mkdir) if -d $t_mkdir; - open STDERR, '>', $err; - is(system(@vg, $exe, "socket_dir:$t_mkdir"), 0, "listen in new dir"); - is($end_err->(), '', 'listened quietly on extra dir'); - File::Path::rmtree($t_mkdir); -} - -ok(-S $s, 'socket untouched'); -open STDERR, '>', $err; -isnt(system(@vg, $exe, "socket_dir:$s"), 0, "listen dir on socket fails"); -like($end_err->(), qr/stat.*directory/, 'stat failure shown'); - -# check for fencepost errors -my $len; -if ($^O eq 'linux') { $len = 108 } -elsif ($^O eq 'freebsd') { $len = 104 } -SKIP: { - skip "length unknown on $^O OS", 2 if !defined($len); - $len -= length("$tmp"); - $len -= length("\0//$TEST_PID.sock"); - my $max = "$tmp/".('x'x$len); - open STDERR, '>', $err; - is(system(@vg, $exe, "socket_dir:$max"), 0, "listen dir on max"); - is($end_err->(), '', 'nothing in stderr on max'); - - open STDERR, '>', $err; - isnt(system(@vg, $exe, "socket_dir:$max+"), 0, "listen dir too long"); - isnt($end_err->(), '', 'stderr contains error when too long'); -} - -done_testing; @@ -11,8 +11,10 @@ my $f1 = "$mwrap_tmp/f1"; my $f2 = "$mwrap_tmp/f2"; mkfifo($f1, 0600) // plan(skip_all => "mkfifo: $!"); mkfifo($f2, 0600) // plan(skip_all => "mkfifo: $!"); -my $pid = mwrap_run('httpd test', $env, '-e', - "open my \$f1, '>', '$f1'; close \$f1; open my \$f2, '<', '$f2'"); +my $src = $mwrap_src ? # $mwrap_src is Perl-only, Ruby otherwise + "open my \$f1, '>', '$f1'; close \$f1; open my \$f2, '<', '$f2'" : + "File.open('$f1', 'w').close; File.open('$f2', 'r').close"; +my $pid = mwrap_run('httpd test', $env, '-e', $src); my $spid; my $mw_exit; my $cleanup = sub { @@ -85,9 +87,21 @@ SKIP: { } SKIP: { + my (@rproxy, @missing); + if (-e 'script/mwrap-rproxy') { # Perl version + @rproxy = ($^X, '-w', './blib/script/mwrap-rproxy'); + } else { + my $exe = `which mwrap-rproxy`; + if ($? == 0 && defined($exe)) { + chomp($rproxy[0] = $exe); + } else { + push @missing, 'mwrap-rproxy'; + } + } for my $m (qw(Plack::Util HTTP::Tiny)) { - eval "require $m" or skip "$m missing", 1; + eval "require $m" or push(@missing, $m); } + skip join(', ', @missing).' missing', 1 if @missing; my $srv = IO::Socket::INET->new(LocalAddr => '127.0.0.1', ReuseAddr => 1, Proto => 'tcp', Type => SOCK_STREAM, @@ -103,8 +117,7 @@ SKIP: { } local $ENV{PLACK_ENV} = 'deployment' if !$ENV{V}; no warnings 'exec'; - exec $^X, '-w', './blib/script/mwrap-rproxy', - "--socket-dir=$mwrap_tmp"; + exec @rproxy, "--socket-dir=$mwrap_tmp"; _exit(1); } my $http = HTTP::Tiny->new; @@ -135,19 +148,28 @@ SKIP: { SKIP: { skip 'no reset w/o curl --unix-socket', 1 if !$curl_unix; - + my ($sqlite_v) = (`sqlite3 --version` =~ /([\d+\.]+)/); + if ($?) { + diag 'sqlite3 missing or broken'; + $sqlite_v = 0; + } else { + my @v = split(/\./, $sqlite_v); + $sqlite_v = ($v[0] << 16) | ($v[1] << 8) | $v[2]; + diag 'sqlite_v='.sprintf('0x%x', $sqlite_v); + } $rc = system(@curl, "http://0/$pid/each/100.csv"); is($rc, 0, '.csv retrieved') or skip 'CSV failed', 1; my $db = "$mwrap_tmp/t.sqlite3"; - $rc = system(qw(sqlite3), $db, ".import --csv $cout mwrap_each"); - if ($rc == -1) { - diag 'sqlite3 missing'; - } else { + + if ($sqlite_v >= 0x32000) { + $rc = system(qw(sqlite3), $db,".import --csv $cout mwrap_each"); is($rc, 0, 'sqlite3 import'); my $n = `sqlite3 $db 'SELECT COUNT(*) FROM mwrap_each'`; is($?, 0, 'sqlite3 count'); my $exp = split(/\n/, slurp($cout)); is($n + 1, $exp, 'imported all rows into sqlite'); + } else { + diag "sqlite 3.32.0+ needed for `.import --csv'"; } $rc = system(@curl, qw(-d x=y), "http://0/$pid/reset"); diff --git a/t/mwrap.t b/t/mwrap.t deleted file mode 100644 index 6f99715..0000000 --- a/t/mwrap.t +++ /dev/null @@ -1,177 +0,0 @@ -#!perl -w -# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -use v5.12; -BEGIN { require './t/test_common.perl' }; -use_ok 'Devel::Mwrap'; -my $dump = "$mwrap_tmp/dump"; - -{ - my $env = { MWRAP => "dump_path:$dump,dump_min:10000" }; - my $nr = 1000; - mwrap_run('dump test', $env, '-e', '$x = "hello world" x '.$nr); - ok(-s $dump, "dump file written to"); - my $s = slurp($dump); - truncate($dump, 0); - my $re = qr/([0-9]+)[ \t]+([0-9]+)[ \t]+-e:1[ \t]*\n/sm; - my ($bytes, $n); - if ($s =~ $re) { - ($bytes, $n) = ($1, $2); - ok($bytes >= (length('hello world') * $nr), - "counted 'hello world' x $nr"); - ok($n >= 1, 'allocation counted'); - } else { - fail("$s failed to match $re"); - } -} - -SKIP: { # C++ program which uses malloc via "new" - my $exp = `cmake -h`; - skip 'cmake missing', 2 if $?; - skip "`cmake -h' gave no output", 2 unless $exp =~ /\S/s; - mwrap_run('cmake (C++ new)', {}, '-e', 'system(qw(cmake -h)); exit $?'); - my $res = slurp($mwrap_out); - is($res, $exp, "`cmake -h' works"); - diag slurp($mwrap_err); -}; - -{ - mwrap_run('total_bytes*', {}, '-e', <<'E1'); -my $A = Devel::Mwrap::total_bytes_allocated(); -my $f = Devel::Mwrap::total_bytes_freed(); -print("$A - $f\n"); -E1 - my $o = slurp($mwrap_out); - like($o, qr/^([0-9]+) - ([0-9]+)\n/s, 'got allocated & freed bytes'); -} - -{ - mwrap_run('source location', {}, 't/source_location.perl'); - mwrap_run('source location via -d:', {}, - '-d:Mwrap', 't/source_location.perl'); -} - -mwrap_run('Devel::Mwrap::each', {}, '-e', <<'EOF'); -open my $zero, '<', '/dev/zero' or die "open /dev/zero: $!"; -my $nbytes = 1024 * 512; -sysread($zero, my $before, $nbytes); -my (@keep, @uargs); -my $uarg = 'user-arg'; -eval { - Devel::Mwrap::each(0, sub { - my $ua = shift; - push @uargs, $ua; - die "died in each"; - push @keep, @_; - }, $uarg) }; -"$@" =~ /died in each at -e line \d+/ or die "did not propagate die in each"; -scalar(@keep) == 0 or die "nothing if died in sub"; -$uarg eq join('-', @uargs) or die "uarg passed to sub"; -my %h; -my $iter; -my $arg = "FOO"; -Devel::Mwrap::each(1, sub { - my ($argh, $src_loc, @more) = @_; - my $name = $src_loc->name; - $h{$name} = $src_loc; - sysread($zero, my $iter, $nbytes); - die 'extra args from ::each' if @more; - die "arg mismatch $arg / $argh" if $argh ne $arg; -}, $arg); -my $src_loc = $h{"-e:3"} or die "missing src_loc for -e:3"; -$src_loc->total >= $nbytes or die "allocated <= $nbytes"; -$src_loc = Devel::Mwrap::get("-e:8"); -if ($src_loc && $src_loc->total >= $nbytes) { - die "large allocation inside :each should not be tracked"; -} -my $nr = 0; -Devel::Mwrap::each($nbytes, sub { - $foo += shift; - push @keep, @_; -}, 1); -scalar(@keep) == 1 or die "got multiple matches for > $nbytes"; -$keep[0]->name eq '-e:3' or die "unexpected location for > $nbytes"; -@keep = (); -Devel::Mwrap::reset(); -Devel::Mwrap::each($nbytes, sub { push @keep, @_ }); -scalar(@keep) == 0 or die "::reset did not work"; -EOF - -mwrap_run('Devel::Mwrap::SrcLoc::each', {}, '-e', <<'EOF'); -open my $zero, '<', '/dev/zero' or die "open /dev/zero: $!"; -my @keep; -my $nr = 10; -my $nbytes = 1024 * 10; -sub do_read () { - sysread($zero, my $buf, $nbytes); - # this forces us to allocate a new buf with every call - pop @keep; - push @keep, $buf; -} -for (1..$nr) { do_read() } -my $loc = Devel::Mwrap::get('-e:6'); -$loc && $loc->total >= ($nbytes * $nr) or die "wrong line or bad stats"; -my $ml = $loc->mean_lifespan; -$ml >= 0.0 or die "mean_lifespan broken"; -my @sl_each; -$loc->each($nbytes, sub { shift; push @sl_each, \@_ }); -my $n = scalar(@sl_each); -$n == 1 or die "SrcLoc::each returned unexpected: $n"; -$sl_each[0]->[0] >= $nbytes or die "$sl_each[0]->[0] < $nbytes"; - -my $age_before = $sl_each[0]->[1]; -$nbytes = 1024 * 1024 * 8; -do_read() until Devel::Mwrap::current_age() > ($age_before + $nbytes); -@sl_each = (); -$loc->each($nbytes, sub { shift; push @sl_each, \@_ }); -$n = scalar(@sl_each); -$n == 1 or die "SrcLoc::each returned unexpected: $n"; -$sl_each[0]->[0] >= $nbytes or die "$sl_each[0]->[0] < $nbytes"; -my $age_after = $sl_each[0]->[1]; -$age_after >= $age_before or die "age did not increment"; -EOF -diag slurp($mwrap_out); - -is(Devel::Mwrap::quiet(1), 0, 'was not quiet, before'); -is(Devel::Mwrap::quiet(0), 1, 'was quiet, before'); - -SKIP: { - eval { require Inline::C } or skip 'Inline::C not available', 1; - $ENV{TEST_ALIASES} or skip 'TEST_ALIASES unset', 1; - my $c_src = <<'EOM'; -#include <stdlib.h> -void cfree(void *); /* lold glibc version */ -int test_aliases() -{ - size_t i; - void *p; - for (i = 0; i < 100; i++) { - if (i % 3 == 0) - p = aligned_alloc(64, i); - else - p = malloc(i); - if (i % 2 == 0) - cfree(p); - else - free(p); - } - return 3; -} -EOM - eval <<'EOM'; -use Inline C => $c_src, BUILD_NOISY => 1 -EOM - BAIL_OUT "cannot build $@" if $@; - is(test_aliases(), 3, - 'aligned_alloc + cfree function ran w/o crashing'); -}; - -is(Devel::Mwrap::bt_depth(), 0, 'default bt depth is zero'); -is(Devel::Mwrap::bt_depth(5), 5, 'set depth to reasonable level'); -is(Devel::Mwrap::bt_depth(), 5, 'depth stays at 5'); -is(Devel::Mwrap::bt_depth(500), 32, 'depth clamped to 32 when 500 attempted'); -is(Devel::Mwrap::bt_depth(), 32, 'depth stayed clamped at 32'); -is(Devel::Mwrap::bt_depth(undef), 32, 'depth stayed clamped at 32'); -is(Devel::Mwrap::bt_depth(-1), 32, 'depth stayed clamped at 32'); - -done_testing; diff --git a/t/source_location.perl b/t/source_location.perl deleted file mode 100644 index ed81ed8..0000000 --- a/t/source_location.perl +++ /dev/null @@ -1,9 +0,0 @@ -use Devel::Mwrap; -my $foo = ('hello world' x 10000); -my $k = __FILE__ . ":2"; -my $loc = Devel::Mwrap::get($k) or die; -$loc->name eq $k or die; -$loc->total >= 10000 or die; -$loc->allocations >= 1 or die; -$loc->frees >= 0 or die; -exit 0; diff --git a/t/test_common.perl b/t/test_common.perl index 8827362..3a073cf 100644 --- a/t/test_common.perl +++ b/t/test_common.perl @@ -6,8 +6,9 @@ use v5.12; use parent qw(Exporter); use Test::More; use File::Temp 0.19 (); # 0.19 for ->newdir -our $mwrap_src = slurp('blib/script/mwrap-perl'); -our $mwrap_tmp = File::Temp->newdir('mwrap-perl-XXXX', TMPDIR => 1); +our $mwrap_src; +$mwrap_src = slurp('blib/script/mwrap-perl') if -e 'script/mwrap-perl'; +our $mwrap_tmp = File::Temp->newdir('mwrap-XXXX', TMPDIR => 1); our $mwrap_out = "$mwrap_tmp/out"; our $mwrap_err = "$mwrap_tmp/err"; our @EXPORT = qw(mwrap_run slurp $mwrap_err $mwrap_out $mwrap_src $mwrap_tmp); @@ -20,9 +21,6 @@ sub slurp { sub mwrap_run { my ($msg, $env, @args) = @_; - unless (grep(/\A-.+\bMwrap\b/, @args)) { - unshift @args, '-MDevel::Mwrap'; - } my $pid = fork; if ($pid == 0) { while (my ($k, $v) = each %$env) { @@ -30,8 +28,16 @@ sub mwrap_run { } open STDERR, '>', $mwrap_err or die "open: $!"; open STDOUT, '>', $mwrap_out or die "open: $!"; - @ARGV = ($^X, @args); - eval $mwrap_src; + if (defined $mwrap_src) { + unless (grep(/\A-.+\bMwrap\b/, @args)) { + unshift @args, '-MDevel::Mwrap'; + } + @ARGV = ($^X, @args); + eval $mwrap_src; + } else { + my $ruby = $ENV{RUBY} // 'ruby'; + exec $ruby, '-Ilib', 'bin/mwrap', $ruby, @args; + } die "fail: $! ($@)"; } if (defined(wantarray)) { |