t/befunge/m-lib.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 #          Library semantics.          #
  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 # Basic loading.
  50 sel; # normal
  51 $bef->store_code( <<'END_OF_CODE' );
  52 "OLEH" 4 ( P q
  53 END_OF_CODE
  54 $bef->run_code;
  55 $out = slurp;
  56 is( $out, "Hello world!\n" );
  57
  58 sel; # interact with IP
  59 $bef->store_code( <<'END_OF_CODE' );
  60 "OLEH" 4 ( S > :# #, _ q
  61 END_OF_CODE
  62 $bef->run_code;
  63 $out = slurp;
  64 is( $out, "Hello world!\n" );
  65
  66 sel; # unknown extension
  67 $bef->store_code( <<'END_OF_CODE' );
  68 "JAVA" 4 #v( 2. q
  69  q . 1    <
  70 END_OF_CODE
  71 $bef->run_code;
  72 $out = slurp;
  73 is( $out, "1 " );
  74
  75 sel; # negative fingerprint
  76 $bef->store_code( <<'END_OF_CODE' );
  77 f- 1 (
  78 END_OF_CODE
  79 eval { $bef->run_code; };
  80 like( $@, qr/Attempt to build a fingerprint with a negative number/,
  81       "loading a library with a negative fingerprint barfs" );
  82 BEGIN { $tests += 4 };
  83
  84
  85 # Overloading.
  86 sel;
  87 $bef->store_code( <<'END_OF_CODE' );
  88 "OLEH" 4 ( "OOF" 3 ( P q
  89 END_OF_CODE
  90 $bef->run_code;
  91 $out = slurp;
  92 is( $out, "foo" );
  93 BEGIN { $tests += 1 };
  94
  95
  96 # Inheritance.
  97 sel;
  98 $bef->store_code( <<'END_OF_CODE' );
  99 "OLEH" 4 ( "OOF" 3 ( S > :# #, _ q
 100 END_OF_CODE
 101 $bef->run_code;
 102 $out = slurp;
 103 is( $out, "Hello world!\n" );
 104 BEGIN { $tests += 1 };
 105
 106
 107 # Unloading.
 108 sel; # normal unloading.
 109 $bef->store_code( <<'END_OF_CODE' );
 110 "OLEH" 4 ( "OOF" 3 ( P ) P q
 111 END_OF_CODE
 112 $bef->run_code;
 113 $out = slurp;
 114 is( $out, "fooHello world!\n" );
 115
 116 sel; # unloading under stack.
 117 $bef->store_code( <<'END_OF_CODE' );
 118 "OLEH" 4 ( "OOF" 3 ( P "OLEH" 4 ) P #v S 2.q
 119                                 q.1  <
 120 END_OF_CODE
 121 $bef->run_code;
 122 $out = slurp;
 123 is( $out, "foofoo1 " );
 124
 125 sel; # unloading non-loaded extension.
 126 $bef->store_code( <<'END_OF_CODE' );
 127 "OLEH" 4 ( "JAVA" 4 #v ) 2.q
 128                 q.1  <
 129 END_OF_CODE
 130 $bef->run_code;
 131 $out = slurp;
 132 is( $out, "1 " );
 133
 134 sel; # negative fingerprint
 135 $bef->store_code( <<'END_OF_CODE' );
 136 f- 1 )
 137 END_OF_CODE
 138 eval { $bef->run_code; };
 139 like( $@, qr/Attempt to build a fingerprint with a negative number/,
 140       "unloading a library with a negative fingerprint barfs" );
 141 BEGIN { $tests += 4 };
 142
 143
 144 BEGIN { plan tests => $tests };