view release on metacpan or  search on metacpan

util/leak-check.pl  view on Meta::CPAN

use warnings;

use Cwd qw(abs_path getcwd);
use File::Basename qw(dirname);
use File::Path qw(make_path remove_tree);
use File::Spec;
use File::Temp qw(tempdir);
use Getopt::Long qw(GetOptions);
my @requested_cases;
my $build_dir;
my $keep_build_dir = 0;
my $help = 0;
my $backend = (($^O // '') eq 'darwin') ? 'leaks' : 'asan';

GetOptions(
  'case=s@' => \@requested_cases,
  'build-dir=s' => \$build_dir,
  'keep-build-dir!' => \$keep_build_dir,
  'backend=s' => \$backend,
  'help' => \$help,
) or usage(1);

usage(0) if $help;

my $repo_root = abs_path(File::Spec->catdir(dirname(abs_path($0)), File::Spec->updir));
my %cases = (
  parser_public => {
    description => 'public parser surface (canonical AST, block strings, errors)',
    command => [ qw(perl -Iblib/lib -Iblib/arch t/21_public_parser_api.t) ],
  },
  execution => {
    description => 'sync runtime execution coverage',
    command => [ qw(perl -Iblib/lib -Iblib/arch t/15_runtime_execute.t) ],
  },
  vm_execute => {
    description => 'native VM execution coverage',
    command => [ qw(perl -Iblib/lib -Iblib/arch t/19_vm_execute.t) ],
  },
  promise => {
    description => 'Promise::XS async execution coverage',
    command => [ qw(perl -Iblib/lib -Iblib/arch t/16_runtime_promise.t) ],
  },
  aliases => {
    description => 'field alias handling across execution lanes',
    command => [ qw(perl -Iblib/lib -Iblib/arch t/29_field_aliases.t) ],
  },
  persisted => {
    description => 'persisted program / bundle round trips',
    command => [ qw(perl -Iblib/lib -Iblib/arch t/22_persisted_queries.t) ],
  },
  oneof => {
    description => 'oneOf coercion including croaking error paths',
    command => [ qw(perl -Iblib/lib -Iblib/arch t/33_oneof_input_objects.t) ],
  },
  croak_safety => {
    description => 'escaped die recovery on the exec-state lane',
    command => [ qw(perl -Iblib/lib -Iblib/arch t/34_exec_state_croak_safety.t) ],
  },
  soak => {
    description => 'long-running worker RSS soak (short profile)',
    command => [ qw(perl -Iblib/lib -Iblib/arch util/soak-test.pl --iterations 3000 --warmup 1000) ],
  },
);

my @case_names = @requested_cases
  ? @requested_cases
  : qw(parser_public execution vm_execute promise aliases persisted oneof croak_safety soak);
for my $name (@case_names) {
  die "Unknown leak-check case: $name\n" unless exists $cases{$name};
}
die "Unknown backend: $backend\n" unless $backend eq 'asan' || $backend eq 'leaks';

$build_dir ||= tempdir('houtou-leak-check-XXXXXX', TMPDIR => 1, CLEANUP => !$keep_build_dir);
$build_dir = abs_path($build_dir);

stage_repo($repo_root, $build_dir);
build_copy($build_dir, $backend);

my @failures;
for my $name (@case_names) {
  my $result = run_case($build_dir, $name, $cases{$name});
  push @failures, $result if !$result->{ok};
}

say "";
say "Leak check summary:";
for my $name (@case_names) {
  my ($failure) = grep { $_->{name} eq $name } @failures;
  if ($failure) {
    say "  FAIL $name";
  } else {
    say "  PASS $name";
  }
}

say "Build directory kept at: $build_dir" if $keep_build_dir;

if (@failures) {
  say "";
  for my $failure (@failures) {
    say "Case $failure->{name} failed:";
    say $failure->{reason};
    say "Log: $failure->{log}";
    say "";
  }
  exit 1;
}

exit 0;

sub build_copy {
  my ($dir, $selected_backend) = @_;
  my @configure = qw(perl Build.PL);
  if ($selected_backend eq 'asan') {
    push @configure,
      q(--extra_compiler_flags=-O1 -g -fno-omit-frame-pointer -fsanitize=address),
      q(--extra_linker_flags=-fsanitize=address);
  }

  run_command(
    dir => $dir,