t/5-befunge/k-system.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 #          System stuff.          #
  13 #---------------------------------#
  14
  15 use strict;
  16 use File::Spec::Functions qw{ catfile };
  17 use Language::Befunge;
  18 use POSIX qw! tmpnam !;
  19 use Test::More;
  20
  21 # Vars.
  22 my $file;
  23 my $fh;
  24 my $tests;
  25 my $out;
  26 my $bef = Language::Befunge->new;
  27 BEGIN { $tests = 0 };
  28
  29 # In order to see what happens...
  30 sub sel () {
  31     $file = tmpnam();
  32     open OUT, ">$file" or die $!;
  33     $fh = select OUT;
  34 }
  35 sub slurp () {
  36     select $fh;
  37     close OUT;
  38     open OUT, "<$file" or die $!;
  39     my $content;
  40     {
  41         local $/;
  42         $content = <OUT>;
  43     }
  44     close OUT;
  45     unlink $file;
  46     return $content;
  47 }
  48
  49 # exec instruction.
  50 SKIP: {
  51     skip 'will barf on windows...', 1 if $^O eq 'MSWin32';
  52
  53     sel; # unknown file.
  54     $bef->store_code( '< q . = "a_file_unlikely_to_exist"0' );
  55     {
  56         local $SIG{__WARN__} = sub {};
  57         $bef->run_code;
  58     }
  59     $out = slurp;
  60     is( $out, "-1 " );
  61 }
  62 sel; # normal system-ing.
  63 $bef->store_code( <<'END_OF_CODE' );
  64 < q . = "perl t/_resources/exit3.pl"0
  65 END_OF_CODE
  66 $bef->run_code;
  67 $out = slurp;
  68 is( $out, "3 " );
  69 BEGIN { $tests += 2 };
  70
  71 # System info retrieval.
  72 sel; # 1. flags.
  73 $bef->store_code( <<'END_OF_CODE' );
  74 1y.q
  75 END_OF_CODE
  76 $bef->run_code;
  77 $out = slurp;
  78 is( $out, "15 " );
  79 BEGIN { $tests += 1 };
  80
  81 sel; # 2. size of funge integers in bytes.
  82 $bef->store_code( <<'END_OF_CODE' );
  83 2y.q
  84 END_OF_CODE
  85 $bef->run_code;
  86 $out = slurp;
  87 is( $out, "4 " );
  88 BEGIN { $tests += 1 };
  89
  90 sel; # 3. handprint.
  91 $bef->store_code( <<'END_OF_CODE' );
  92 3y.q
  93 END_OF_CODE
  94 $bef->run_code;
  95 $out = slurp;
  96 my $handprint = 0;
  97 $handprint = $handprint*256 + ord($_) for split //, $bef->get_handprint;
  98 is( $out, "$handprint " );
  99 BEGIN { $tests += 1 };
 100
 101 sel; # 4. version of interpreter.
 102 $bef->store_code( <<'END_OF_CODE' );
 103 4y.q
 104 END_OF_CODE
 105 $bef->run_code;
 106 $out = slurp;
 107 my $ver = $Language::Befunge::VERSION;
 108 $ver =~ s/\.//g;
 109 is( $out, "$ver " );
 110 BEGIN { $tests += 1 };
 111
 112 sel; # 5. ID Code
 113 $bef->store_code( <<'END_OF_CODE' );
 114 5y.q
 115 END_OF_CODE
 116 $bef->run_code;
 117 $out = slurp;
 118 is( $out, "1 " );
 119 BEGIN { $tests += 1 };
 120
 121 sel; # 6. path separator.
 122 $bef->store_code( <<'END_OF_CODE' );
 123 6y,q
 124 END_OF_CODE
 125 $bef->run_code;
 126 $out = slurp;
 127 is( $out, catfile('','') );
 128 BEGIN { $tests += 1 };
 129
 130 sel; # 7. size of funge (2D).
 131 $bef->store_code( <<'END_OF_CODE' );
 132 7y.q
 133 END_OF_CODE
 134 $bef->run_code;
 135 $out = slurp;
 136 is( $out, "2 " );
 137 BEGIN { $tests += 1 };
 138
 139 sel; # 8. IP id.
 140 $bef->store_code( <<'END_OF_CODE' );
 141 8y.q
 142 END_OF_CODE
 143 $bef->run_code;
 144 $out = slurp;
 145 like( $out, qr/^\d+ $/ );
 146 BEGIN { $tests += 1 };
 147
 148 sel; # 9. NetFunge (unimplemented).
 149 $bef->store_code( <<'END_OF_CODE' );
 150 9y.q
 151 END_OF_CODE
 152 $bef->run_code;
 153 $out = slurp;
 154 is( $out, "0 " );
 155 BEGIN { $tests += 1 };
 156
 157 sel; # 10. pos of IP.
 158 $bef->store_code( <<'END_OF_CODE' );
 159 a v
 160   > y..q
 161 END_OF_CODE
 162 $bef->run_code;
 163 $out = slurp;
 164 is( $out, "1 4 " );
 165 BEGIN { $tests += 1 };
 166
 167 sel; # 11. delta of IP.
 168 $bef->store_code( <<'END_OF_CODE' );
 169 v .
 170     q
 171 >b  21x
 172         y
 173           .
 174 END_OF_CODE
 175 $bef->run_code;
 176 $out = slurp;
 177 is( $out, "1 2 " );
 178 BEGIN { $tests += 1 };
 179
 180 sel; # 12. Storage offset.
 181 $bef->store_code( <<'END_OF_CODE' );
 182    0   {  cy..q
 183 END_OF_CODE
 184 $bef->run_code;
 185 $out = slurp;
 186 is( $out, "0 8 " );
 187 BEGIN { $tests += 1 };
 188
 189 sel; # 13. top-left corner of Lahey space.
 190 $bef->store_code( <<'END_OF_CODE' );
 191 6 03-04-p  dy..q
 192 END_OF_CODE
 193 $bef->run_code;
 194 $out = slurp;
 195 is( $out, "-4 -3 " );
 196 BEGIN { $tests += 1 };
 197
 198 sel; # 14. bottom-right corner of Lahey space.
 199 $bef->store_code( <<'END_OF_CODE' );
 200 6 ff+8p 6 03-04-p ey..q
 201 END_OF_CODE
 202 $bef->run_code;
 203 $out = slurp;
 204 is( $out, "12 33 " );
 205 BEGIN { $tests += 1 };
 206
 207 sel; # 15. Date.
 208 my ($s,$m,$h,$dd,$mm,$yy)=localtime;
 209 my $date = $yy*256*256+$mm*256+$dd;
 210 my $time = $h*256*256+$m*256+$s;
 211 $bef->store_code( <<'END_OF_CODE' );
 212 fy.q
 213 END_OF_CODE
 214 $bef->run_code;
 215 $out = slurp;
 216 chop($out); # remove trailing space.
 217 is( $out >= $date,   1); # There is a tiny little chance
 218 is( $out <= $date+1, 1); # that the date has changed.
 219 BEGIN { $tests += 2 };
 220
 221 sel; # 16. Time.
 222 $bef->store_code( <<'END_OF_CODE' );
 223 88+y.q
 224 END_OF_CODE
 225 $bef->run_code;
 226 $out = slurp;
 227 chop($out); # remove trailing space.
 228 is( $out >= $time,   1);  # The two tests should not take
 229 is( $out <= $time+15, 1); # more than 15 seconds.
 230 BEGIN { $tests += 2 };
 231
 232 sel; # 17. Size of stack stack.
 233 $bef->store_code( <<'END_OF_CODE' );
 234 0{0{0{0{ 89+y. 0}0} 89+y.q
 235 END_OF_CODE
 236 $bef->run_code;
 237 $out = slurp;
 238 is( $out, "5 3 " );
 239 BEGIN { $tests += 1 };
 240
 241 sel; # 18. Size of each stack.
 242 $bef->store_code( <<'END_OF_CODE' );
 243 123 0{ 12 0{ 987654 99+y...q
 244 END_OF_CODE
 245 $bef->run_code;
 246 $out = slurp;
 247 is( $out, "6 4 5 " );
 248 BEGIN { $tests += 1 };
 249
 250 sel; # 19. Args.
 251 $bef->store_code( <<'END_OF_CODE' );
 252 a9+y >  :#, _ $a, :#v _q
 253      ^              <
 254 END_OF_CODE
 255 $bef->run_code( "foo", 7, "bar" );
 256 $out = slurp;
 257 is( $out, "STDIN\nfoo\n7\nbar\n" );
 258 BEGIN { $tests += 1 };
 259
 260 sel; # 20. %ENV.
 261 %ENV= ( LANG   => "C",
 262         LC_ALL => "C",
 263       );
 264 $bef->store_code( <<'END_OF_CODE' );
 265 v                > $ ;EOL; a,  v
 266            > :! #^_ ,# #! #: <
 267 >  2a*y  : | ;new pair;   :    <
 268            q
 269 END_OF_CODE
 270 $bef->run_code;
 271 $out = slurp;
 272 is( $out, "LANG=C\nLC_ALL=C\n" );
 273 BEGIN { $tests += 1 };
 274
 275 sel; # negative.
 276 $bef->store_code( <<'END_OF_CODE' );
 277 02-y...q
 278 END_OF_CODE
 279 $bef->run_code;
 280 $out = slurp;
 281 is( $out, "15 4 $handprint " );
 282 BEGIN { $tests += 1 };
 283
 284 sel; # pick in stack.
 285 $bef->store_code( <<'END_OF_CODE' );
 286 1234567 b2*y.q
 287 END_OF_CODE
 288 $bef->run_code;
 289 $out = slurp;
 290 is( $out, "6 " );
 291 BEGIN { $tests += 1 };
 292
 293 BEGIN { plan tests => $tests };