t/4-interpreter/befunge.t

   1 #!perl
   2 #
   3 # This file is part of Language::Befunge.
   4 # Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the same terms as Perl itself.
   8 #
   9 #
  10
  11 #-----------------------------------#
  12 #          Exported funcs.          #
  13 #-----------------------------------#
  14
  15 use strict;
  16 use Language::Befunge;
  17 use POSIX qw! tmpnam !;
  18 use Test::More;
  19
  20 # Vars.
  21 my ($file, $fh);
  22 my $tests;
  23 my $out;
  24 my $bef = Language::Befunge->new;
  25 BEGIN { $tests = 0 };
  26
  27 # In order to see what happens...
  28 sub sel () {
  29     $file = tmpnam();
  30     open OUT, ">$file" or die $!;
  31     $fh = select OUT;
  32 }
  33 sub slurp () {
  34     select $fh;
  35     close OUT;
  36     open OUT, "<$file" or die $!;
  37     my $content;
  38     {
  39         local $/;
  40         $content = <OUT>;
  41     }
  42     close OUT;
  43     unlink $file;
  44     return $content;
  45 }
  46
  47 # Basic constructor.
  48 sel;
  49 $bef = Language::Befunge->new( {file => "t/_resources/q.bf"} );
  50 $bef->run_code;
  51 $out = slurp;
  52 is( $out, "" );
  53 BEGIN { $tests += 1 };
  54
  55 # debug tests.
  56 {
  57     my $warning;
  58     local $SIG{__WARN__} = sub { $warning = "@_" };
  59     $bef = Language::Befunge->new;
  60
  61     $warning = "";
  62     $bef->debug( "foo\n" );
  63     is( $warning, "", "DEBUG is off by default" );
  64
  65     $warning = "";
  66     $bef->set_DEBUG(1);
  67     $bef->debug( "bar\n" );
  68     is( $warning, "bar\n", "debug warns properly when DEBUG is on" );
  69
  70     $warning = "";
  71     $bef->set_DEBUG(0);
  72     $bef->debug( "baz\n" );
  73     is( $warning, "",      "debug does not warn when DEBUG is off" );
  74 }
  75 BEGIN { $tests += 3 };
  76
  77
  78 # Basic reading.
  79 $bef = Language::Befunge->new;
  80 sel;
  81 $bef->read_file( "t/_resources/q.bf" );
  82 $bef->run_code;
  83 $out = slurp;
  84 is( $out, "" );
  85 BEGIN { $tests += 1 };
  86
  87 # Reading a non existent file.
  88 eval { $bef->read_file( "/dev/a_file_that_is_not_likely_to_exist" ); };
  89 like( $@, qr/line/, "reading a non-existent file barfs" );
  90 BEGIN { $tests += 1 };
  91
  92 # Basic storing.
  93 sel;
  94 $bef->store_code( <<'END_OF_CODE' );
  95 q
  96 END_OF_CODE
  97 $bef->run_code;
  98 $out = slurp;
  99 is( $out, "" );
 100 BEGIN { $tests += 1 };
 101
 102 # Interpreter must treat non-characters as if they were an 'r' instruction.
 103 sel;
 104 $bef->store_code( <<'END_OF_CODE' );
 105 01-b0p#q1.2 q
 106 END_OF_CODE
 107 $bef->run_code;
 108 $out = slurp;
 109 is( $out, "1 2 " );
 110 BEGIN { $tests += 1 };
 111
 112 # Interpreter must treat non-commands as if they were an 'r' instruction.
 113 sel;
 114 $bef->store_code( <<'END_OF_CODE' );
 115 01+b0p#q1.2 q
 116 END_OF_CODE
 117 $bef->run_code;
 118 $out = slurp;
 119 is( $out, "1 2 " );
 120 BEGIN { $tests += 1 };
 121
 122 # Befunge Interpreter treats High/Low instructions as unknown characters.
 123 sel;
 124 $bef->store_code( <<"END_OF_CODE" );
 125 1#q.2h3.q
 126 END_OF_CODE
 127 $bef->run_code;
 128 $out = slurp;
 129 is( $out, "1 2 " );
 130 BEGIN { $tests += 1 };
 131
 132 BEGIN { plan tests => $tests };