t/20system.t

   1 #!perl
   2 #
   3 # This file is part of Language::Befunge.
   4 # Copyright (c) 2001-2007 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 Language::Befunge;
  17 use Config;
  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/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 is( $out, "JQBF980 " );
  97 BEGIN { $tests += 1 };
  98
  99 sel; # 4. version of interpreter.
 100 $bef->store_code( <<'END_OF_CODE' );
 101 4y.q
 102 END_OF_CODE
 103 $bef->run_code;
 104 $out = slurp;
 105 my $ver = $Language::Befunge::VERSION;
 106 $ver =~ s/\.//g;
 107 is( $out, "$ver " );
 108 BEGIN { $tests += 1 };
 109
 110 sel; # 5. ID Code
 111 $bef->store_code( <<'END_OF_CODE' );
 112 5y.q
 113 END_OF_CODE
 114 $bef->run_code;
 115 $out = slurp;
 116 is( $out, "1 " );
 117 BEGIN { $tests += 1 };
 118
 119 sel; # 6. path separator.
 120 $bef->store_code( <<'END_OF_CODE' );
 121 6y,q
 122 END_OF_CODE
 123 $bef->run_code;
 124 $out = slurp;
 125 is( $out, $Config{path_sep} );
 126 BEGIN { $tests += 1 };
 127
 128 sel; # 7. size of funge (2D).
 129 $bef->store_code( <<'END_OF_CODE' );
 130 7y.q
 131 END_OF_CODE
 132 $bef->run_code;
 133 $out = slurp;
 134 is( $out, "2 " );
 135 BEGIN { $tests += 1 };
 136
 137 sel; # 8. IP id.
 138 $bef->store_code( <<'END_OF_CODE' );
 139 8y.q
 140 END_OF_CODE
 141 $bef->run_code;
 142 $out = slurp;
 143 like( $out, qr/^\d+ $/ );
 144 BEGIN { $tests += 1 };
 145
 146 sel; # 9. NetFunge (unimplemented).
 147 $bef->store_code( <<'END_OF_CODE' );
 148 9y.q
 149 END_OF_CODE
 150 $bef->run_code;
 151 $out = slurp;
 152 is( $out, "0 " );
 153 BEGIN { $tests += 1 };
 154
 155 sel; # 10. pos of IP.
 156 $bef->store_code( <<'END_OF_CODE' );
 157 a v
 158   > y..q
 159 END_OF_CODE
 160 $bef->run_code;
 161 $out = slurp;
 162 is( $out, "1 4 " );
 163 BEGIN { $tests += 1 };
 164
 165 sel; # 11. delta of IP.
 166 $bef->store_code( <<'END_OF_CODE' );
 167 v .
 168     q
 169 >b  21x
 170         y
 171           .
 172 END_OF_CODE
 173 $bef->run_code;
 174 $out = slurp;
 175 is( $out, "1 2 " );
 176 BEGIN { $tests += 1 };
 177
 178 sel; # 12. Storage offset.
 179 $bef->store_code( <<'END_OF_CODE' );
 180    0   {  cy..q
 181 END_OF_CODE
 182 $bef->run_code;
 183 $out = slurp;
 184 is( $out, "0 8 " );
 185 BEGIN { $tests += 1 };
 186
 187 sel; # 13. top-left corner of Lahey space.
 188 $bef->store_code( <<'END_OF_CODE' );
 189 6 03-04-p  dy..q
 190 END_OF_CODE
 191 $bef->run_code;
 192 $out = slurp;
 193 is( $out, "-4 -3 " );
 194 BEGIN { $tests += 1 };
 195
 196 sel; # 14. bottom-right corner of Lahey space.
 197 $bef->store_code( <<'END_OF_CODE' );
 198 6 ff+8p 6 03-04-p ey..q
 199 END_OF_CODE
 200 $bef->run_code;
 201 $out = slurp;
 202 is( $out, "13 34 " );
 203 BEGIN { $tests += 1 };
 204
 205 sel; # 15. Date.
 206 my ($s,$m,$h,$dd,$mm,$yy)=localtime;
 207 my $date = $yy*256*256+$mm*256+$dd;
 208 my $time = $h*256*256+$m*256+$s;
 209 $bef->store_code( <<'END_OF_CODE' );
 210 fy.q
 211 END_OF_CODE
 212 $bef->run_code;
 213 $out = slurp;
 214 chop($out); # remove trailing space.
 215 is( $out >= $date,   1); # There is a tiny little chance
 216 is( $out <= $date+1, 1); # that the date has changed.
 217 BEGIN { $tests += 2 };
 218
 219 sel; # 16. Time.
 220 $bef->store_code( <<'END_OF_CODE' );
 221 88+y.q
 222 END_OF_CODE
 223 $bef->run_code;
 224 $out = slurp;
 225 chop($out); # remove trailing space.
 226 is( $out >= $time,   1);  # The two tests should not take
 227 is( $out <= $time+15, 1); # more than 15 seconds.
 228 BEGIN { $tests += 2 };
 229
 230 sel; # 17. Size of stack stack.
 231 $bef->store_code( <<'END_OF_CODE' );
 232 0{0{0{0{ 89+y. 0}0} 89+y.q
 233 END_OF_CODE
 234 $bef->run_code;
 235 $out = slurp;
 236 is( $out, "5 3 " );
 237 BEGIN { $tests += 1 };
 238
 239 sel; # 18. Size of each stack.
 240 $bef->store_code( <<'END_OF_CODE' );
 241 123 0{ 12 0{ 987654 99+y...q
 242 END_OF_CODE
 243 $bef->run_code;
 244 $out = slurp;
 245 is( $out, "6 4 5 " );
 246 BEGIN { $tests += 1 };
 247
 248 sel; # 19. Args.
 249 $bef->store_code( <<'END_OF_CODE' );
 250 a9+y >  :#, _ $a, :#v _q
 251      ^              <
 252 END_OF_CODE
 253 $bef->run_code( "foo", 7, "bar" );
 254 $out = slurp;
 255 is( $out, "STDIN\nfoo\n7\nbar\n" );
 256 BEGIN { $tests += 1 };
 257
 258 sel; # 20. %ENV.
 259 %ENV= ( LANG   => "C",
 260         LC_ALL => "C",
 261       );
 262 $bef->store_code( <<'END_OF_CODE' );
 263 v                > $ ;EOL; a,  v
 264            > :! #^_ ,# #! #: <
 265 >  2a*y  : | ;new pair;   :    <
 266            q
 267 END_OF_CODE
 268 $bef->run_code;
 269 $out = slurp;
 270 is( $out, "LANG=C\nLC_ALL=C\n" );
 271 BEGIN { $tests += 1 };
 272
 273 sel; # negative.
 274 $bef->store_code( <<'END_OF_CODE' );
 275 02-y..,,,,,,q
 276 END_OF_CODE
 277 $bef->run_code;
 278 $out = slurp;
 279 is( $out, "15 4 JQBF98" );
 280 BEGIN { $tests += 1 };
 281
 282 sel; # pick in stack.
 283 $bef->store_code( <<'END_OF_CODE' );
 284 1234567 b2*y.q
 285 END_OF_CODE
 286 $bef->run_code;
 287 $out = slurp;
 288 is( $out, "6 " );
 289 BEGIN { $tests += 1 };
 290
 291 BEGIN { plan tests => $tests };