From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on dcvr.yhbt.net X-Spam-Level: X-Spam-ASN: X-Spam-Status: No, score=-4.1 required=3.0 tests=ALL_TRUSTED,AWL,BAYES_00, DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF shortcircuit=no autolearn=ham autolearn_force=no version=3.4.2 Received: from localhost (dcvr.yhbt.net [127.0.0.1]) by dcvr.yhbt.net (Postfix) with ESMTP id F11931F61C for ; Sat, 10 Dec 2022 01:55:18 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=80x24.org; s=selector1; t=1670637319; bh=L/NTGF22oW5lXWbUrto3V+MXoG3JO6u6LNyvZxlQJrQ=; h=From:To:Subject:Date:In-Reply-To:References:From; b=NkRRyApMcbvtMowl7pgnT3rHR9ykWUdCb/VtvApeiqRzOvSCYoAisIQBFlRDwsWfE lB76endWQTcZkY1+QJ8hQOmceIF7+2sxQz2m2mBwwCLrljnsGQveRhEuu8UwN35R7R hn6Ugu7WPL2IGUKyjRhU40NTDzL3rHqSjFDc6Sfc= From: Eric Wong To: mwrap-perl@80x24.org Subject: [PATCH 2/3] tests: hoist out test_common.perl Date: Sat, 10 Dec 2022 01:55:17 +0000 Message-Id: <20221210015518.272576-3-e@80x24.org> In-Reply-To: <20221210015518.272576-1-e@80x24.org> References: <20221210015518.272576-1-e@80x24.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit List-Id: This will make it easier to split out tests to separate files in the future. --- MANIFEST | 1 + t/mwrap.t | 47 +++++++-------------------------------------- t/test_common.perl | 48 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 56 insertions(+), 40 deletions(-) create mode 100644 t/test_common.perl diff --git a/MANIFEST b/MANIFEST index eb8098e..c732c56 100644 --- a/MANIFEST +++ b/MANIFEST @@ -17,4 +17,5 @@ ppport.h script/mwrap-perl t/mwrap.t t/source_location.perl +t/test_common.perl typemap diff --git a/t/mwrap.t b/t/mwrap.t index 0bb3ea8..bf6ae6e 100644 --- a/t/mwrap.t +++ b/t/mwrap.t @@ -2,15 +2,9 @@ # Copyright (C) mwrap hackers # License: GPL-2.0+ use v5.12; -use Test::More; -use File::Temp qw(tempdir); +BEGIN { require './t/test_common.perl' }; use_ok 'Devel::Mwrap'; - -my $tmpdir = tempdir('mwrap-perl-XXXX', TMPDIR => 1, CLEANUP => 1); -my $dump = "$tmpdir/dump"; -my $out = "$tmpdir/out"; -my $err = "$tmpdir/err"; -my $src = slurp('blib/script/mwrap-perl'); +my $dump = "$mwrap_tmp/dump"; { my $env = { MWRAP => "dump_path:$dump,dump_min:10000" }; @@ -36,9 +30,9 @@ SKIP: { # C++ program which uses malloc via "new" 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($out); + my $res = slurp($mwrap_out); is($res, $exp, "`cmake -h' works"); - diag slurp($err); + diag slurp($mwrap_err); }; { @@ -47,7 +41,7 @@ my $A = Devel::Mwrap::total_bytes_allocated(); my $f = Devel::Mwrap::total_bytes_freed(); print("$A - $f\n"); E1 - my $o = slurp($out); + my $o = slurp($mwrap_out); like($o, qr/^([0-9]+) - ([0-9]+)\n/s, 'got allocated & freed bytes'); } @@ -136,7 +130,7 @@ $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($out); +diag slurp($mwrap_out); is(Devel::Mwrap::quiet(1), 0, 'was not quiet, before'); is(Devel::Mwrap::quiet(0), 1, 'was quiet, before'); @@ -172,31 +166,4 @@ EOM 'aligned_alloc + cfree function ran w/o crashing'); }; -done_testing(); - -sub slurp { - open my $fh, '<', $_[0] or die "open($_[0]): $!"; - local $/; - <$fh>; -} - -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) { - $ENV{$k} = $v; - } - open STDERR, '>', $err or die "open: $!"; - open STDOUT, '>', $out or die "open: $!"; - @ARGV = ($^X, @args); - eval $src; - die "fail: $! ($@)"; - } - waitpid($pid, 0); - is($?, 0, $msg); - diag "err: ".slurp($err) if $?; -} +done_testing; diff --git a/t/test_common.perl b/t/test_common.perl new file mode 100644 index 0000000..94da8f4 --- /dev/null +++ b/t/test_common.perl @@ -0,0 +1,48 @@ +#!perl -w +# Copyright (C) mwrap hackers +# License: GPL-2.0+ +package MwrapTest; +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_out = "$mwrap_tmp/out"; +our $mwrap_err = "$mwrap_tmp/err"; +our @EXPORT = qw(mwrap_run slurp $mwrap_err $mwrap_out $mwrap_src $mwrap_tmp); + +sub slurp { + open my $fh, '<', $_[0] or die "open($_[0]): $!"; + local $/; + <$fh>; +} + +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) { + $ENV{$k} = $v; + } + open STDERR, '>', $mwrap_err or die "open: $!"; + open STDOUT, '>', $mwrap_out or die "open: $!"; + @ARGV = ($^X, @args); + eval $mwrap_src; + die "fail: $! ($@)"; + } + if (defined(wantarray)) { + return $pid if !wantarray; + die "BUG: list return value not supported\n"; + } + waitpid($pid, 0); + is($?, 0, $msg); + diag "err: ".slurp($mwrap_err) if $?; +} +package main; +MwrapTest->import; +Test::More->import; +1;