view release on metacpan or  search on metacpan

t/devel-dtrace.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More;
use Test::Differences;

use constant IS_SOLARIS => ( $^O =~ /solaris/ );

my @scripts = map { [ $_, reference( $_ ) ] }
 @ARGV ? @ARGV : glob 't/scripts/*.pl';

my @methods
 = ( [ 'module', $^X, ( map { "-I$_" } @INC ), '-MDevel::DTrace' ], );

if ( $] >= 5.008008 && !IS_SOLARIS ) {
  push @methods, [ 'dtperl', './dtperl' ];
}

plan tests => 1 * @scripts * @methods;

for my $method ( @methods ) {
  my ( $type, @cmd ) = @$method;
  for my $script ( @scripts ) {
    my ( $name, $todo, $want ) = @$script;
    my $got = dtrace_run( @cmd, $name );

    if ( @$want && $want->[0] eq ':tail:' ) {
      $want = [ @{$want}[ 1 .. $#$want ] ];
      $got  = [ @{$got}[ $#$got - $#$want .. $#$got ] ];
    }

    TODO: {
      local $TODO = $todo if $todo;
      eq_or_diff $got, $want, "$type, $name: ok";
    }
  }
}

sub reference {
  my $scp  = shift;
  my @out  = ();
  my $todo = undef;
  local $_;
  open my $sh, '<', $scp or die "Can't read $scp ($!)\n";
  while ( <$sh> ) {
    chomp;
    $todo = $1 if /# TODO\s+(.+)/;
    next if $. == 1 .. /^__DATA__$/;
    push @out, $_;
  }
  return ( $todo, \@out );
}

sub dtrace_run {
  my @cmd = @_;
  local $ENV{'DEVEL_DTRACE_RUNOPS_FAKE'} = 1;
  open my $proc, '-|', @cmd or die "Can't run @cmd ($!)\n";
  chomp( my @out = <$proc> );
  close $proc or die "@cmd failed ($!)\n";
  return \@out;
}