view release on metacpan or  search on metacpan

t/test_alien.t  view on Meta::CPAN

    my($mod) = @_;
    is($mod->answer, 42);
  };

  my $cbuilder_config;

  no warnings 'once';
  local *ExtUtils::CBuilder::new = do {
    my $orig = ExtUtils::CBuilder->can('new');
    sub {
      my $class = shift;
      my %args = @_;
      $cbuilder_config = $args{config};
      $class->$orig(@_);
    };
  };

  xs_ok { xs => $xs, cbuilder_config => { foo => 'bar' } };

  is
    $cbuilder_config,
    hash {
      field 'foo' => 'bar';
      etc;
    }
  ;

};

subtest 'with_subtest SEGV' => sub {

  # it may be possible to catch a segmentation fault,
  # but not with signal handlers apparently.  See:
  # https://feepingcreature.github.io/handling.html
  skip_all 'Catching SEGV not currently supported on Windows' if $^O eq 'MSWin32';

  skip_all 'Test requires platforms with SEGV signal' if ! any { $_ eq 'SEGV' } split /\s+/, $Config{sig_name};

  our $kill_line;

  my $st = with_subtest {
    note 'one';
    kill 'SEGV', $$; BEGIN { $kill_line = __LINE__ };
    note 'two';
  };

  my $e;

  is(
    $e = intercept {
      $st->();
    },
    array {
      event Note => sub {
        call message => 'one';
      };
      event Bail => sub {
        call reason => 'Segmentation fault';
        call facet_data => hash {
          field trace => hash {
            field frame => array {
              item 'main';
              item __FILE__;
              item $kill_line;
              etc;
            };
            etc;
          };
          etc;
        };
        etc;
      };
      end;
    },
  ) or diag _dump($e);

};

subtest 'diagnostic when calling tools without alien_ok' => sub {

  _reset();
  require_compiler;

  my $xs = <<'EOF';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

MODULE = TA_MODULE PACKAGE = TA_MODULE

int answer();
  CODE:
    RETVAL = 1;
EOF

  is
    intercept { xs_ok { xs => $xs } },
    array {
      event Note => {} if $ENV{TEST_ALIEN_ALWAYS_KEEP};
      event Ok => sub {
        call pass => T();
        call name => 'xs';
      };
      event Diag => sub {
        call message => 'xs_ok called without any aliens, you may want to call alien_ok';
      };
      end;
    },
    'xs_ok displays dignostic sans alien_ok',
  ;

  is
    intercept { run_ok [$^X, -e => '1'] },
    array {
      event Ok => sub {
        call pass => T();
        call name => match qr/^run/;
      };
      event Note => sub {};
      event Diag => sub {
        call message => 'run_ok called without any aliens, you may want to call alien_ok';