lib/open.t

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