lib/open.t

   1 #!./perl
   2
   3 BEGIN {
   4         chdir 't' if -d 't';
   5         @INC = '../lib';
   6         push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
   7         require Config; import Config;
   8 }
   9
  10 use Test::More tests => 17;
  11
  12 # open::import expects 'open' as its first argument, but it clashes with open()
  13 sub import {
  14         open::import( 'open', @_ );
  15 }
  16
  17 # can't use require_ok() here, with a name like 'open'
  18 ok( require 'open.pm', 'requiring open' );
  19
  20 # this should fail
  21 eval { import() };
  22 like( $@, qr/needs explicit list of PerlIO layers/,
  23         'import should fail without args' );
  24
  25 # the hint bits shouldn't be set yet
  26 is( $^H & $open::hint_bits, 0,
  27         'hint bits should not be set in $^H before open import' );
  28
  29 # prevent it from loading I18N::Langinfo, so we can test encoding failures
  30 my $warn;
  31 local $SIG{__WARN__} = sub {
  32         $warn .= shift;
  33 };
  34
  35 # and it shouldn't be able to find this layer
  36 $warn = '';
  37 eval q{ no warnings 'layer'; use open IN => ':macguffin' ; };
  38 is( $warn, '',
  39         'should not warn about unknown layer with bad layer provided' );
  40
  41 $warn = '';
  42 eval q{ use warnings 'layer'; use open IN => ':macguffin' ; };
  43 like( $warn, qr/Unknown PerlIO layer/,
  44         'should warn about unknown layer with bad layer provided' );
  45
  46 SKIP: {
  47     skip("no perlio, no :utf8", 1) unless (find PerlIO::Layer 'perlio');
  48     skip("no Encode for locale layer", 1) unless eval { require Encode };
  49     # now load a real-looking locale
  50     $ENV{LC_ALL} = ' .utf8';
  51     import( 'IN', 'locale' );
  52     like( ${^OPEN}, qr/^(:utf8)?:utf8\0/,
  53         'should set a valid locale layer' );
  54 }
  55
  56 # and see if it sets the magic variables appropriately
  57 import( 'IN', ':crlf' );
  58 ok( $^H & $open::hint_bits,
  59         'hint bits should be set in $^H after open import' );
  60 is( $^H{'open_IN'}, 'crlf', 'should have set crlf layer' );
  61
  62 # it should reset them appropriately, too
  63 import( 'IN', ':raw' );
  64 is( $^H{'open_IN'}, 'raw', 'should have reset to raw layer' );
  65
  66 # it dies if you don't set IN, OUT, or IO
  67 eval { import( 'sideways', ':raw' ) };
  68 like( $@, qr/Unknown PerlIO layer class/, 'should croak with unknown class' );
  69
  70 # but it handles them all so well together
  71 import( 'IO', ':raw :crlf' );
  72 is( ${^OPEN}, ":raw :crlf\0:raw :crlf",
  73         'should set multi types, multi layer' );
  74 is( $^H{'open_IO'}, 'crlf', 'should record last layer set in %^H' );
  75
  76 SKIP: {
  77     skip("no perlio, no :utf8", 4) unless (find PerlIO::Layer 'perlio');
  78
  79     eval <<EOE;
  80     use open ':utf8';
  81     open(O, ">utf8");
  82     print O chr(0x100);
  83     close O;
  84     open(I, "<utf8");
  85     is(ord(<I>), 0x100, ":utf8 single wide character round-trip");
  86     close I;
  87 EOE
  88
  89     open F, ">a";
  90     @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
  91     unshift @a, chr(0); # ... and a null byte in front just for fun
  92     print F @a;
  93     close F;
  94
  95     sub systell {
  96         use Fcntl 'SEEK_CUR';
  97         sysseek($_[0], 0, SEEK_CUR);
  98     }
  99
 100     require bytes; # not use
 101
 102     my $ok;
 103
 104     open F, "<:utf8", "a";
 105     $ok = $a = 0;
 106     for (@a) {
 107         unless (
 108                 ($c = sysread(F, $b, 1)) == 1  &&
 109                 length($b)               == 1  &&
 110                 ord($b)                  == ord($_) &&
 111                 systell(F)               == ($a += bytes::length($b))
 112                 ) {
 113             print '# ord($_)           == ', ord($_), "\n";
 114             print '# ord($b)           == ', ord($b), "\n";
 115             print '# length($b)        == ', length($b), "\n";
 116             print '# bytes::length($b) == ', bytes::length($b), "\n";
 117             print '# systell(F)        == ', systell(F), "\n";
 118             print '# $a                == ', $a, "\n";
 119             print '# $c                == ', $c, "\n";
 120             last;
 121         }
 122         $ok++;
 123     }
 124     close F;
 125     ok($ok == @a,
 126        "on :utf8 streams sysread() should work on characters, not bytes");
 127
 128     # syswrite() on should work on characters, not bytes
 129     open G, ">:utf8", "b";
 130     $ok = $a = 0;
 131     for (@a) {
 132         unless (
 133                 ($c = syswrite(G, $_, 1)) == 1 &&
 134                 systell(G)                == ($a += bytes::length($_))
 135                 ) {
 136             print '# ord($_)           == ', ord($_), "\n";
 137             print '# bytes::length($_) == ', bytes::length($_), "\n";
 138             print '# systell(G)        == ', systell(G), "\n";
 139             print '# $a                == ', $a, "\n";
 140             print '# $c                == ', $c, "\n";
 141             print "not ";
 142             last;
 143         }
 144         $ok++;
 145     }
 146     close G;
 147     ok($ok == @a,
 148        "on :utf8 streams syswrite() should work on characters, not bytes");
 149
 150     open G, "<:utf8", "b";
 151     $ok = $a = 0;
 152     for (@a) {
 153         unless (
 154                 ($c = sysread(G, $b, 1)) == 1 &&
 155                 length($b)               == 1 &&
 156                 ord($b)                  == ord($_) &&
 157                 systell(G)               == ($a += bytes::length($_))
 158                 ) {
 159             print '# ord($_)           == ', ord($_), "\n";
 160             print '# ord($b)           == ', ord($b), "\n";
 161             print '# length($b)        == ', length($b), "\n";
 162             print '# bytes::length($b) == ', bytes::length($b), "\n";
 163             print '# systell(G)        == ', systell(G), "\n";
 164             print '# $a                == ', $a, "\n";
 165             print '# $c                == ', $c, "\n";
 166             last;
 167         }
 168         $ok++;
 169     }
 170     close G;
 171     ok($ok == @a,
 172        "checking syswrite() output on :utf8 streams by reading it back in");
 173 }
 174
 175 SKIP: {
 176     skip("no perlio", 1) unless (find PerlIO::Layer 'perlio');
 177     use open IN => ':non-existent';
 178     eval {
 179         require Symbol; # Anything that exists but we havn't loaded
 180     };
 181     like($@, qr/Can't locate Symbol|Recursive call/i,
 182          "test for an endless loop in PerlIO_find_layer");
 183 }
 184
 185 END {
 186     1 while unlink "utf8";
 187     1 while unlink "a";
 188     1 while unlink "b";
 189 }
 190
 191 # the test cases beyond __DATA__ need to be executed separately
 192
 193 __DATA__
 194 $ENV{LC_ALL} = 'nonexistent.euc';
 195 eval { open::_get_locale_encoding() };
 196 like( $@, qr/too ambiguous/, 'should die with ambiguous locale encoding' );
 197 %%%
 198 # the special :locale layer
 199 $ENV{LC_ALL} = $ENV{LANG} = 'ru_RU.KOI8-R';
 200 # the :locale will probe the locale environment variables like LANG
 201 use open OUT => ':locale';
 202 open(O, ">koi8");
 203 print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
 204 close O;
 205 open(I, "<koi8");
 206 printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
 207 close I;
 208 %%%