<commit_before>package Parrot::Test::Tcl;

=head1

Provide language specific testing routines here...

This is currently alarmingly similar to the generated subs in Parrot::Test.
Perhaps someone can do a better job of delegation here.

=cut

sub new {
  return bless {};
}

sub output_is() {

  my ($self, $code, $output, $desc) = @_;
  
  $count = $self->{builder}->current_test + 1;

  $desc = $language unless $desc;
  
  my $lang_f = Parrot::Test::per_test('.tcl',$count);
  my $out_f = Parrot::Test::per_test('.out',$count);

  $TEST_PROG_ARGS = $ENV{TEST_PROG_ARGS} || '';
  my $args = $TEST_PROG_ARGS;

  # flatten filenames (don't use directories)
  $lang_f = (File::Spec->splitpath($lang_f))[2];
  $out_f =  (File::Spec->splitpath($out_f))[2];
  # but, always put the test in a tempdir, so we're not cluttering
  $lang_f = File::Spec->catfile(File::Spec->tmpdir(),$lang_f);
  $out_f = File::Spec->catfile(File::Spec->tmpdir(),$out_f);
  Parrot::Test::generate_pbc_for( $code, $count, $lang_f );

  my $cmd;
  my $exit_code = 0;
  my $pass = 0;

  $cmd = "(cd " . $self->{relpath} . " && " . $self->{parrot} . " languages/tcl/tcl.pbc ${args} $lang_f)";

  # For some reason, if you redirect both STDERR and STDOUT here, 
  # you get a 38M file of garbage. We'll temporarily assume everything
  # works and ignore stderr.
  $exit_code = Parrot::Test::_run_command($cmd, STDOUT => $out_f);
  
  unless ($pass) {
    my $file = Parrot::Test::slurp_file($out_f);
    $pass =$self->{builder}->is_eq( Parrot::Test::slurp_file($out_f), $output, $desc );
    $self->{builder}->diag("'$cmd' failed with exit code $exit_code")
      if $exit_code and not $pass;
  }

  unless($ENV{POSTMORTEM}) {
    unlink $lang_f;
    unlink $out_f;
  }
<commit_msg>- Parrot::Test::generate_pbc_for do need the $directory arg<commit_after>package Parrot::Test::Tcl;

use File::Basename;

=head1

Provide language specific testing routines here...

This is currently alarmingly similar to the generated subs in Parrot::Test.
Perhaps someone can do a better job of delegation here.

=cut

sub new {
  return bless {};
}

sub output_is() {

  my ($self, $code, $output, $desc) = @_;
  
  $count = $self->{builder}->current_test + 1;

  $desc = $language unless $desc;
  
  my $lang_f = Parrot::Test::per_test('.tcl',$count);
  my $out_f = Parrot::Test::per_test('.out',$count);
  my $parrotdir = dirname $self->{parrot};

  $TEST_PROG_ARGS = $ENV{TEST_PROG_ARGS} || '';
  my $args = $TEST_PROG_ARGS;

  # flatten filenames (don't use directories)
  $lang_f = (File::Spec->splitpath($lang_f))[2];
  $out_f =  (File::Spec->splitpath($out_f))[2];
  # but, always put the test in a tempdir, so we're not cluttering
  $lang_f = File::Spec->catfile(File::Spec->tmpdir(),$lang_f);
  $out_f = File::Spec->catfile(File::Spec->tmpdir(),$out_f);
  Parrot::Test::generate_pbc_for( $code, $parrotdir, $count, $lang_f );

  my $cmd;
  my $exit_code = 0;
  my $pass = 0;

  $cmd = "(cd " . $self->{relpath} . " && " . $self->{parrot} . " languages/tcl/tcl.pbc ${args} $lang_f)";

  # For some reason, if you redirect both STDERR and STDOUT here, 
  # you get a 38M file of garbage. We'll temporarily assume everything
  # works and ignore stderr.
  $exit_code = Parrot::Test::_run_command($cmd, STDOUT => $out_f);
  
  unless ($pass) {
    my $file = Parrot::Test::slurp_file($out_f);
    $pass =$self->{builder}->is_eq( Parrot::Test::slurp_file($out_f), $output, $desc );
    $self->{builder}->diag("'$cmd' failed with exit code $exit_code")
      if $exit_code and not $pass;
  }

  unless($ENV{POSTMORTEM}) {
    unlink $lang_f;
    unlink $out_f;
  }

{'fraction_non_alphanumeric': 0.17541436464088397, 'fraction_numerical': 0.004419889502762431, 'mean_word_length': 4.172857142857143, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 34, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '883438', 'n_tokens_mistral': 1412, 'n_tokens_neox': 1368, 'n_words': 333}