view release on metacpan or  search on metacpan

lib/Acme/AsciiArtinator.pm  view on Meta::CPAN

  if (defined $opts{"code_file"}) {
    my $fh;
    local $/ = undef;
    open($fh, "<", $opts{"code_file"}) || croak "Invalid  code_file  specification: $!\n";
    $CODE = <$fh>;
    close $fh;
  } elsif ($opts{"code_string"}) {
    $CODE = $opts{"code_string"};
  } elsif ($opts{"code"}) {
    $CODE = $opts{"code"};
  } else {
    croak "Invalid spec. Must specify  code, code_file,  or  code_string \n";
  }

  if (defined $opts{"output"}) {
    $OUTPUT = $opts{"output"};
  } else {
    print STDERR "Output will go to \"ascii-art.pl\"\n" if $DEBUG;
    $OUTPUT = "ascii-art.pl";
  }

  if (defined $opts{"compile-check"}) {
    my $fh;
    open($fh, ">", "ascii-art.$$.pl");
    print $fh $CODE;
    close $fh;

    my $c1 = &compile_check("ascii-art.$$.pl");
    unlink "ascii-art.$$.pl";
    if ($c1 > 0) {
      croak "Initial code in ",$opts{"code"},$opts{"code_string"},
	    $opts{"code_file"}," does not compile!\n";
    }
  }

  my $ntest = 1;
  while (defined $opts{"test_argv$ntest"} || defined $opts{"test_input$ntest"}) {
    my (@test_argv, @test_stdin) = ();

    @test_argv = @{$opts{"test_argv$ntest"}} if defined $opts{"test_argv$ntest"};
    @test_stdin = @{$opts{"test_input$ntest"}} if defined $opts{"test_input$ntest"};
    my $fh;
    if (open($fh, ">", "ascii-art-test-$ntest-$$.pl")) {
      print $fh $CODE;
      close $fh;

      my $output = "";
      if (defined $opts{"test_input$ntest"}) {
	open($fh, ">", "ascii-art-test-$ntest-$$.stdin");
	print $fh @test_stdin;
	close $fh;
	print qq{Running test: $^X ascii-art-test-$ntest-$$.pl @test_argv < ascii-art-test-$ntest-$$.stdin\n} if $DEBUG;
	$output = qx{$^X ascii-art-test-$ntest-$$.pl @test_argv < ascii-art-test-$ntest-$$.stdin};
	unlink "ascii-art-test-$ntest-$$.stdin";
      } else {
	print qq{Running test: $^X ascii-art-test-$ntest-$$.pl @test_argv\n};
	$output = qx{$^X ascii-art-test-$ntest-$$.pl @test_argv};
      }
      print "Ran pre-test # $ntest with argv: \"@test_argv\", stdin: \"@test_stdin\"\n";

      $Acme::AsciiArtinator::TestOutput[$ntest] = $output;
      unlink "ascii-art-test-$ntest-$$.pl";
    } else {
      carp "Could not write code to disk in order to run pre-test.\n";
    }
  } continue {
    $ntest++;
  }


  ###############################################

  my $max_tries = $opts{"retry"} || 100;


  my @tokens = &asciiindex_code($CODE);
  my @contexts = @asciiartinate::contexts;
  my @blocks = &asciiindex_art($PIC);

  my $ipad;
  for ($ipad = 0; $ipad < $max_tries; $ipad++) {
    print "\n\n\n\nPad try # $ipad\n\n\n\n"; 

    my ($newt,$newc) = &pad(\@tokens, \@contexts, \@blocks);
    if (defined $newc) {

      for (my $i=0; $i<@$newt; $i++) {
	print $newt->[$i], "\t", $newc->[$i], "\n";
      }

      @tokens = @$newt;

      if ($opts{"filler"} != 0) {
	&tweak_padding($opts{"filler"}, \@tokens, \@contexts);
      }

      print_code_to_pic($PIC, @tokens);

      my $fh;
      open($fh, ">", $OUTPUT);
      select $fh;
      print_code_to_pic($PIC, @tokens);
      select STDOUT;
      close $fh;

      my $c1 = &compile_check($OUTPUT);
      if ($c1 > 0) {
	croak "Artinated code does not compile! Darn.\n";
	exit $c1 >> 8;
      }

      ##################################################
      #
      # artination complete
      #
      ##################################################

      open($fh,"<", $OUTPUT);
      my @output = <$fh>;
      close $fh;

      # test output
      #
      # make sure artinated code produces same outputs
      # as the original code on the test cases.
      #
      $ntest = 1;
      if (defined $opts{"test_argv1"}) {
	print "Running post-tests on artinated code\n";
      }
      while (defined $opts{"test_argv$ntest"} || defined $opts{"test_input$ntest"}) {
	my (@test_argv, @test_stdin) = ();

	print "Testing output # $ntest:\n";

	@test_argv = @{$opts{"test_argv$ntest"}} if defined $opts{"test_argv$ntest"};
	@test_stdin = @{$opts{"test_input$ntest"}} if defined $opts{"test_input$ntest"};
	my $fh;
	next if !defined $Acme::AsciiArtinator::TestOutput[$ntest];

	my $output = "";
	if (defined $opts{"test_input$ntest"}) {
	  open($fh, ">", "ascii-art-test-$ntest-$$.stdin");
	  print $fh @test_stdin;
	  close $fh;
	  $output = qx{$^X "$OUTPUT" @test_argv < ascii-art-test-$ntest-$$.stdin};
	  unlink "ascii-art-test-$ntest-$$.stdin";
	} else {
	  $output = qx{$^X "$OUTPUT" @test_argv};
	}
	print "Ran post-test # $ntest with argv: \"@test_argv\", stdin: \"@test_stdin\"\n";
    
	if ($output eq $Acme::AsciiArtinator::TestOutput[$ntest]) {
	  print "Post-test # $ntest: PASS\n";
	  $Acme::AsciiArtinator::TestResult[$ntest] = "PASS";
	} else {
	  print "Post-test # $ntest: FAIL\n";
	  $Acme::AsciiArtinator::TestResult[$ntest] = "FAIL";
	  print STDERR "-- " x 13, "\n";
	  print STDERR "Original results for test # $ntest:\n";
	  print STDERR "-- " x 7, "\n";
	  print STDERR $Acme::AsciiArtinator::TestOutput[$ntest];
	  print STDERR "\n", "-- " x 13, "\n";
	  print STDERR "Final results for test # $ntest:\n";
	  print STDERR $output;
	  print STDERR "\n", "-- " x 13, "\n\n";
	}
      } continue {
	$ntest++;
      }
      return @output;
    }
  }

  if ($ipad >= $max_tries) {
    croak "The ASCII Artinator was unable to embed your code in the picture ",
      "after $max_tries tries.\n";
  }
}

#
# run a file containing Perl code for a Perl compilation check
#
sub compile_check {
  my ($file) = @_;
  print "\n";
  print "- " x 20, "\n";
  print "Compile check for $file:\n";
  print "- " x 20, "\n";
  print `$^X -cw "$file"`;
  print "- " x 20, "\n";
  return $?;
}

sub tweak_padding {
  my ($filler, $tref, $cref) = @_;

  # TODO: if there are many consecutive characters of padding
  #       in the code, we can improve its appearance by 
  #       inserting some quoted text in void context.

}

#############################################################################
#
# code tokenization -- split code into tokens that should
# not be further divisible by whitespace
#

# You know that this [decompiling Perl code] is impossible, right ?
# http://www.perlmonks.org/index.pl?node_id=44722

my @token_keywords = qw(&&= ||= <<= >>= <=> ... **= //=
   && || ++ -- == != <= >= -> ** =~ !~ 
   <= >= => .. += -= *= /= %= |= &= ^= << >> .= <> //);

# //= is an operator in perl 5.10, I believe
# //  is usually a regular expression, or a perl 5.10 operator

my %sigil = qw($ 1 @ 2 % 3 & 4 & 0);

#