view release on metacpan or  search on metacpan

t/generate/08-codegen-injection.t  view on Meta::CPAN

    *{"${pkg}::import"} = sub { return; };
  }

  # DBIO::Core: usable both as `use base 'DBIO::Core'` and as the method sink
  # for __PACKAGE__->table(...) etc. Provide no-op methods for everything except
  # result_source_instance / meta, which need to return chainable objects below.
  for my $f (@DSL_FUNCS) {
    next if $f eq 'result_source_instance' || $f eq 'meta';
    *{"DBIO::Core::${f}"} = sub { return; };
  }
  # result_source_instance must return an object that also no-ops view_definition
  *{"DBIO::Core::result_source_instance"} = sub {
    return bless {}, 'DBIO::Core::FakeRSI';
  };
  *{"DBIO::Core::FakeRSI::view_definition"} = sub { return; };
  *{"DBIO::Core::meta"} = sub { return bless {}, 'DBIO::Core::FakeMeta'; };
  *{"DBIO::Core::FakeMeta::make_immutable"} = sub { return; };

  # Prime %INC so `use`/`require` of these never hits the real modules.
  for my $pkg (qw(DBIO::Cake DBIO::Candy DBIO::Core Moo Moose
                  MooX::NonMoose MooseX::NonMoose MooseX::MarkAsMethods)) {
    (my $file = "${pkg}.pm") =~ s{::}{/}g;
    $INC{$file} ||= __FILE__;
  }
}

my %style = (
  vanilla => 'DBIO::Generate::Style::Vanilla',
  cake    => 'DBIO::Generate::Style::Cake',
  candy   => 'DBIO::Generate::Style::Candy',
  moo     => 'DBIO::Generate::Style::Moo',
  moose   => 'DBIO::Generate::Style::Moose',
);

my $n = 0;
sub require_generated {
  my ($code, $tag) = @_;
  $n++;
  my $file = File::Spec->catfile($tmpdir, "Gen${n}.pm");
  open my $fh, '>', $file or die "open $file: $!";
  print $fh $code;
  close $fh;

  # Compile/run the generated module exactly like require would.
  unlink $sentinel if -e $sentinel;
  my $ok = eval { require $file; 1 };
  my $err = $@;
  return ($ok, $err, $file);
}

# --- Hostile specs: injected code must NOT run, for every style -------------
my $i = 0;
for my $name (sort keys %style) {
  my $class = "Injection::Test::" . ucfirst($name) . (++$i);
  my $spec  = hostile_spec($class);

  my $code = eval { $style{$name}->emit($spec) };
  ok defined $code, "$name: emit() produced source for hostile spec"
    or do { diag "emit died: $@"; next };

  my ($ok, $err) = require_generated($code, $name);

  # The generated module may or may not compile cleanly (a poisoned identifier
  # safely embedded as a string literal yields valid Perl; we don't require
  # compilation to fail). What MUST hold: no injected code executed.
  ok !-e $sentinel,
    "$name: hostile identifiers did NOT execute injected code (no sentinel)";

  unlink $sentinel if -e $sentinel;
}

# --- Benign negative control: clean spec loads, creates no sentinel ---------
for my $name (sort keys %style) {
  my $class = "Benign::Test::" . ucfirst($name);
  my $spec  = {
    moniker      => 'User',
    class        => $class,
    table        => 'users',
    column_order => [qw/id name/],
    columns      => {
      id   => { data_type => 'integer', is_auto_increment => 1, is_nullable => 0 },
      name => { data_type => 'varchar', size => 100, is_nullable => 1 },
    },
    pk    => [qw/id/],
    uniq  => [],
    relationships => [],
    extra_statements => [],
    is_view => 0,
    view_definition => undef,
    result_base_class => 'DBIO::Core',
    components => [],
    additional_classes => [],
  };

  my $code = $style{$name}->emit($spec);
  my ($ok, $err) = require_generated($code, "benign-$name");
  ok $ok, "$name: benign spec compiles cleanly" or diag $err;
  ok !-e $sentinel, "$name: benign spec creates no sentinel";

  unlink $sentinel if -e $sentinel;
}

# --- Package-name validator must croak on a hostile class -------------------
{
  my $evil_class = q{Foo; BEGIN { open my $f,'>',$ENV{DBIO_INJECTION_SENTINEL} } package Bar};
  for my $name (sort keys %style) {
    my $spec = hostile_spec($evil_class);
    my $code = eval { $style{$name}->emit($spec) };
    ok( !defined($code) && $@,
      "$name: emit() croaks on a hostile package/class name" )
      or diag "expected croak, got code:\n$code";
  }

  # And the helper itself, directly.
  eval { DBIO::Generate::Util::assert_pkg($evil_class) };
  like $@, qr/package name/, 'assert_pkg croaks on hostile package name';

  eval { DBIO::Generate::Util::assert_pkg('My::Schema::Result::User') };
  is $@, '', 'assert_pkg accepts a well-formed package name';
}

ok !-e $sentinel, 'final: sentinel was never created across the whole test';

done_testing;