| 1 | #!./perl
|
|---|
| 2 |
|
|---|
| 3 | BEGIN {
|
|---|
| 4 | chdir 't' if -d 't';
|
|---|
| 5 | @INC = '../lib';
|
|---|
| 6 | unless (find PerlIO::Layer 'perlio') {
|
|---|
| 7 | print "1..0 # Skip: not perlio\n";
|
|---|
| 8 | exit 0;
|
|---|
| 9 | }
|
|---|
| 10 | }
|
|---|
| 11 |
|
|---|
| 12 | no utf8; # needed for use utf8 not griping about the raw octets
|
|---|
| 13 |
|
|---|
| 14 | require "./test.pl";
|
|---|
| 15 |
|
|---|
| 16 | plan(tests => 55);
|
|---|
| 17 |
|
|---|
| 18 | $| = 1;
|
|---|
| 19 |
|
|---|
| 20 | open(F,"+>:utf8",'a');
|
|---|
| 21 | print F chr(0x100).'£';
|
|---|
| 22 | cmp_ok( tell(F), '==', 4, tell(F) );
|
|---|
| 23 | print F "\n";
|
|---|
| 24 | cmp_ok( tell(F), '>=', 5, tell(F) );
|
|---|
| 25 | seek(F,0,0);
|
|---|
| 26 | is( getc(F), chr(0x100) );
|
|---|
| 27 | is( getc(F), "£" );
|
|---|
| 28 | is( getc(F), "\n" );
|
|---|
| 29 | seek(F,0,0);
|
|---|
| 30 | binmode(F,":bytes");
|
|---|
| 31 | my $chr = chr(0xc4);
|
|---|
| 32 | if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC
|
|---|
| 33 | is( getc(F), $chr );
|
|---|
| 34 | $chr = chr(0x80);
|
|---|
| 35 | if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC
|
|---|
| 36 | is( getc(F), $chr );
|
|---|
| 37 | $chr = chr(0xc2);
|
|---|
| 38 | if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC
|
|---|
| 39 | is( getc(F), $chr );
|
|---|
| 40 | $chr = chr(0xa3);
|
|---|
| 41 | if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC
|
|---|
| 42 | is( getc(F), $chr );
|
|---|
| 43 | is( getc(F), "\n" );
|
|---|
| 44 | seek(F,0,0);
|
|---|
| 45 | binmode(F,":utf8");
|
|---|
| 46 | is( scalar(<F>), "\x{100}£\n" );
|
|---|
| 47 | seek(F,0,0);
|
|---|
| 48 | $buf = chr(0x200);
|
|---|
| 49 | $count = read(F,$buf,2,1);
|
|---|
| 50 | cmp_ok( $count, '==', 2 );
|
|---|
| 51 | is( $buf, "\x{200}\x{100}£" );
|
|---|
| 52 | close(F);
|
|---|
| 53 |
|
|---|
| 54 | {
|
|---|
| 55 | $a = chr(300); # This *is* UTF-encoded
|
|---|
| 56 | $b = chr(130); # This is not.
|
|---|
| 57 |
|
|---|
| 58 | open F, ">:utf8", 'a' or die $!;
|
|---|
| 59 | print F $a,"\n";
|
|---|
| 60 | close F;
|
|---|
| 61 |
|
|---|
| 62 | open F, "<:utf8", 'a' or die $!;
|
|---|
| 63 | $x = <F>;
|
|---|
| 64 | chomp($x);
|
|---|
| 65 | is( $x, chr(300) );
|
|---|
| 66 |
|
|---|
| 67 | open F, "a" or die $!; # Not UTF
|
|---|
| 68 | binmode(F, ":bytes");
|
|---|
| 69 | $x = <F>;
|
|---|
| 70 | chomp($x);
|
|---|
| 71 | $chr = chr(196).chr(172);
|
|---|
| 72 | if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC
|
|---|
| 73 | is( $x, $chr );
|
|---|
| 74 | close F;
|
|---|
| 75 |
|
|---|
| 76 | open F, ">:utf8", 'a' or die $!;
|
|---|
| 77 | binmode(F); # we write a "\n" and then tell() - avoid CRLF issues.
|
|---|
| 78 | binmode(F,":utf8"); # turn UTF-8-ness back on
|
|---|
| 79 | print F $a;
|
|---|
| 80 | my $y;
|
|---|
| 81 | { my $x = tell(F);
|
|---|
| 82 | { use bytes; $y = length($a);}
|
|---|
| 83 | cmp_ok( $x, '==', $y );
|
|---|
| 84 | }
|
|---|
| 85 |
|
|---|
| 86 | { # Check byte length of $b
|
|---|
| 87 | use bytes; my $y = length($b);
|
|---|
| 88 | cmp_ok( $y, '==', 1 );
|
|---|
| 89 | }
|
|---|
| 90 |
|
|---|
| 91 | print F $b,"\n"; # Don't upgrades $b
|
|---|
| 92 |
|
|---|
| 93 | { # Check byte length of $b
|
|---|
| 94 | use bytes; my $y = length($b);
|
|---|
| 95 | cmp_ok( $y, '==', 1 );
|
|---|
| 96 | }
|
|---|
| 97 |
|
|---|
| 98 | {
|
|---|
| 99 | my $x = tell(F);
|
|---|
| 100 | { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII
|
|---|
| 101 | cmp_ok( $x, '==', $y );
|
|---|
| 102 | }
|
|---|
| 103 |
|
|---|
| 104 | close F;
|
|---|
| 105 |
|
|---|
| 106 | open F, "a" or die $!; # Not UTF
|
|---|
| 107 | binmode(F, ":bytes");
|
|---|
| 108 | $x = <F>;
|
|---|
| 109 | chomp($x);
|
|---|
| 110 | $chr = v196.172.194.130;
|
|---|
| 111 | if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
|
|---|
| 112 | is( $x, $chr, sprintf('(%vd)', $x) );
|
|---|
|
|---|
