In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/e5d6fe1e14242b8fffff87d546656ae03d9e788c?hp=c951e2ad069531f80b857752d3795306ce8bba2d>
- Log -----------------------------------------------------------------
commit e5d6fe1e14242b8fffff87d546656ae03d9e788c
Author: Karl Williamson <k...@khw-desktop.(none)>
Date: Sun May 30 07:17:52 2010 -0600
Add cautionary comment to .t
M lib/charnames.t
commit d25fba9031046260f5408d849e307a9671bc05b5
Author: Karl Williamson <k...@khw-desktop.(none)>
Date: Sat May 29 13:34:55 2010 -0600
Remove BUG report from pod that is now fixed
viacode now works correctly for 0.
M lib/charnames.pm
commit c8002005105721beeeefa9e31bed53e376f4c7ae
Author: Karl Williamson <k...@khw-desktop.(none)>
Date: Sat May 29 13:29:53 2010 -0600
Fix charnames::viacode not accepting U+... param
The commit e10d7780a27dcfeb9c50ab28b66f2df8763d8016 introduced a bug in
which a parameter to viacode of the form U+... no longer worked. This
is fixed, as well as tests added.
M lib/charnames.pm
M lib/charnames.t
commit a0d8d8c515a8d9a056392064d46fc9031f20e178
Author: Karl Williamson <k...@khw-desktop.(none)>
Date: Sat May 29 13:25:43 2010 -0600
Update charnames.t to modern style
This now uses test.pl to define subroutines that make it easier to
maintain.
M lib/charnames.t
-----------------------------------------------------------------------
Summary of changes:
lib/charnames.pm | 4 +-
lib/charnames.t | 282 +++++++++++++++++++++---------------------------------
2 files changed, 110 insertions(+), 176 deletions(-)
diff --git a/lib/charnames.pm b/lib/charnames.pm
index 2bf36ac..eddf66a 100644
--- a/lib/charnames.pm
+++ b/lib/charnames.pm
@@ -265,7 +265,7 @@ sub viacode
$hex = sprintf "%04X", $arg;
} elsif ($arg =~ /^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/) {
# Below is the line that differs from the _getcode() source
- $hex = sprintf "%04X", hex $arg;
+ $hex = sprintf "%04X", hex $1;
} else {
carp("unexpected arg \"$arg\" to charnames::viacode()");
return;
@@ -557,8 +557,6 @@ past U+10FFFF you do get a warning.) See L</BUGS> below.
viacode should return an empty string for unassigned in-range Unicode code
points, as that is their correct current name.
-viacode(0) doesn't return C<NULL>, but C<undef>
-
vianame returns a chr if the input name is of the form C<U+...>, and an ord
otherwise. It is planned to change this to always return an ord.
diff --git a/lib/charnames.t b/lib/charnames.t
index 144c826..ce2bc34 100644
--- a/lib/charnames.t
+++ b/lib/charnames.t
@@ -1,4 +1,5 @@
#!./perl
+use strict;
my @WARN;
@@ -15,36 +16,37 @@ require File::Spec;
$| = 1;
-print "1..81\n";
+plan(85);
use charnames ':full';
-print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here!?";
-print "ok 1\n";
+is("Here\N{EXCLAMATION MARK}?", "Here!?");
{
- use bytes; # TEST -utf8 can switch utf8 on
+ use bytes; # TEST -utf8 can switch utf8 on
- print "# \$res=$res \...@='$@'\nnot "
- if $res = eval <<'EOE'
+ my $res = eval <<'EOE';
use charnames ":full";
"Here: \N{CYRILLIC SMALL LETTER BE}!";
1
EOE
- or $@ !~ /above 0xFF/;
- print "ok 2\n";
- # print "# \$res=$res \...@='$@'\n";
- print "# \$res=$res \...@='$@'\nnot "
- if $res = eval <<'EOE'
+ like($@, "above 0xFF");
+ is($res, undef);
+
+ $res = eval <<'EOE';
use charnames 'cyrillic';
"Here: \N{Be}!";
1
EOE
- or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/;
- print "ok 3\n";
+ like($@, "CYRILLIC CAPITAL LETTER BE.*above 0xFF");
}
+my $encoded_be;
+my $encoded_alpha;
+my $encoded_bet;
+my $encoded_deseng;
+
# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt
if (ord('A') == 65) { # as on ASCII or UTF-8 machines
$encoded_be = "\320\261";
@@ -67,208 +69,148 @@ sub to_bytes {
{
use charnames ':full';
- print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be;
- print "ok 4\n";
+ is(to_bytes("\N{CYRILLIC SMALL LETTER BE}"), $encoded_be);
use charnames qw(cyrillic greek :short);
- print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}")
- eq "$encoded_be,$encoded_alpha,$encoded_bet";
- print "ok 5\n";
+ is(to_bytes("\N{be},\N{alpha},\N{hebrew:bet}"),
+ "$encoded_be,$encoded_alpha,$encoded_bet");
}
{
use charnames ':full';
- print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}";
- print "ok 6\n";
- print "not " unless length("\x{263a}") == 1;
- print "ok 7\n";
- print "not " unless length("\N{WHITE SMILING FACE}") == 1;
- print "ok 8\n";
- print "not " unless sprintf("%vx", "\x{263a}") eq "263a";
- print "ok 9\n";
- print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a";
- print "ok 10\n";
- print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq
"ff.263a";
- print "ok 11\n";
- print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq
"ff.263a";
- print "ok 12\n";
+ is("\x{263a}", "\N{WHITE SMILING FACE}");
+ cmp_ok(length("\x{263a}"), '==', 1);
+ cmp_ok(length("\N{WHITE SMILING FACE}"), '==', 1);
+ is(sprintf("%vx", "\x{263a}"), "263a");
+ is(sprintf("%vx", "\N{WHITE SMILING FACE}"), "263a");
+ is(sprintf("%vx", "\xFF\N{WHITE SMILING FACE}"), "ff.263a");
+ is(sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}"), "ff.263a");
}
{
- use charnames qw(:full);
- use utf8;
+ use charnames qw(:full);
+ use utf8;
my $x = "\x{221b}";
my $named = "\N{CUBE ROOT}";
- print "not " unless ord($x) == ord($named);
- print "ok 13\n";
+ cmp_ok(ord($x), '==', ord($named));
}
{
- use charnames qw(:full);
- use utf8;
- print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}";
- print "ok 14\n";
+ use charnames qw(:full);
+ use utf8;
+ is("\x{100}\N{CENT SIGN}", "\x{100}"."\N{CENT SIGN}");
}
{
- use charnames ':full';
+ use charnames ':full';
- print "not "
- unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng;
- print "ok 15\n";
+ is(to_bytes("\N{DESERET SMALL LETTER ENG}"), $encoded_deseng);
}
{
- # 20001114.001
-
- no utf8; # naked Latin-1
-
- if (ord("Ä") == 0xc4) { # Try to do this only on Latin-1.
- use charnames ':full';
- my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}";
- print "not " unless $text eq "\xc4" && ord($text) == 0xc4;
- print "ok 16\n";
- } else {
- print "ok 16 # Skip: not Latin-1\n";
- }
+ # 20001114.001
+
+ no utf8; # naked Latin-1
+
+ use charnames ':full';
+ my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}";
+ is($text, latin1_to_native("\xc4"));
+
+ # I'm not sure that this tests anything different from the above.
+ cmp_ok(ord($text), '==', ord(latin1_to_native("\xc4")));
}
{
- print "not " unless charnames::viacode(0x1234) eq "ETHIOPIC SYLLABLE SEE";
- print "ok 17\n";
+ is(charnames::viacode(0x1234), "ETHIOPIC SYLLABLE SEE");
# Unused Hebrew.
- print "not " if defined charnames::viacode(0x0590);
- print "ok 18\n";
+ ok(! defined charnames::viacode(0x0590));
}
{
- print "not " unless
- sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")) eq "10330";
- print "ok 19\n";
-
- print "not " if
- defined charnames::vianame("NONE SUCH");
- print "ok 20\n";
+ is(sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")), "10330");
+ ok (! defined charnames::vianame("NONE SUCH"));
}
{
# check that caching at least hasn't broken anything
- print "not " unless charnames::viacode(0x1234) eq "ETHIOPIC SYLLABLE SEE";
- print "ok 21\n";
+ is(charnames::viacode(0x1234), "ETHIOPIC SYLLABLE SEE");
- print "not " unless
- sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")) eq "10330";
- print "ok 22\n";
+ is(sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")), "10330");
}
-print "not " unless "\N{CHARACTER TABULATION}" eq "\t";
-print "ok 23\n";
-
-print "not " unless "\N{ESCAPE}" eq "\e";
-print "ok 24\n";
-
-print "not " unless "\N{NULL}" eq "\c@";
-print "ok 25\n";
-
-print "not " unless "\N{LINE FEED (LF)}" eq "\n";
-print "ok 26\n";
-
-print "not " unless "\N{LINE FEED}" eq "\n";
-print "ok 27\n";
-
-print "not " unless "\N{LF}" eq "\n";
-print "ok 28\n";
-
-my $nel = ord("A") == 193 ? qr/^(?:\x15|\x25)$/ : qr/^\x85$/;
+is("\N{CHARACTER TABULATION}", "\t");
-print "not " unless "\N{NEXT LINE (NEL)}" =~ $nel;
-print "ok 29\n";
+is("\N{ESCAPE}", "\e");
+is("\N{NULL}", "\c@");
+is("\N{LINE FEED (LF)}", "\n");
+is("\N{LINE FEED}", "\n");
+is("\N{LF}", "\n");
-print "not " unless "\N{NEXT LINE}" =~ $nel;
-print "ok 30\n";
+my $nel = latin1_to_native("\x85");
+$nel = qr/^$nel$/;
-print "not " unless "\N{NEL}" =~ $nel;
-print "ok 31\n";
-
-print "not " unless "\N{BYTE ORDER MARK}" eq chr(0xFEFF);
-print "ok 32\n";
-
-print "not " unless "\N{BOM}" eq chr(0xFEFF);
-print "ok 33\n";
+like("\N{NEXT LINE (NEL)}", $nel);
+like("\N{NEXT LINE}", $nel);
+like("\N{NEL}", $nel);
+is("\N{BYTE ORDER MARK}", chr(0xFEFF));
+is("\N{BOM}", chr(0xFEFF));
{
use warnings 'deprecated';
- print "not " unless "\N{HORIZONTAL TABULATION}" eq "\t";
- print "ok 34\n";
+ is("\N{HORIZONTAL TABULATION}", "\t");
- print "not " unless grep { /"HORIZONTAL TABULATION" is deprecated/ } @WARN;
- print "ok 35\n";
+ ok(grep { /"HORIZONTAL TABULATION" is deprecated/ } @WARN);
no warnings 'deprecated';
- print "not " unless "\N{VERTICAL TABULATION}" eq "\013";
- print "ok 36\n";
+ is("\N{VERTICAL TABULATION}", "\013");
- print "not " if grep { /"VERTICAL TABULATION" is deprecated/ } @WARN;
- print "ok 37\n";
+ ok(! grep { /"VERTICAL TABULATION" is deprecated/ } @WARN);
}
-print "not " unless charnames::viacode(0xFEFF) eq "ZERO WIDTH NO-BREAK SPACE";
-print "ok 38\n";
+is(charnames::viacode(0xFEFF), "ZERO WIDTH NO-BREAK SPACE");
{
use warnings;
- print "not " unless ord("\N{BOM}") == 0xFEFF;
- print "ok 39\n";
+ cmp_ok(ord("\N{BOM}"), '==', 0xFEFF);
}
-print "not " unless ord("\N{ZWNJ}") == 0x200C;
-print "ok 40\n";
+cmp_ok(ord("\N{ZWNJ}"), '==', 0x200C);
-print "not " unless ord("\N{ZWJ}") == 0x200D;
-print "ok 41\n";
+cmp_ok(ord("\N{ZWJ}"), '==', 0x200D);
-print "not " unless "\N{U+263A}" eq "\N{WHITE SMILING FACE}";
-print "ok 42\n";
+is("\N{U+263A}", "\N{WHITE SMILING FACE}");
{
- print "not " unless
- 0x3093 == charnames::vianame("HIRAGANA LETTER N");
- print "ok 43\n";
-
- print "not " unless
- 0x0397 == charnames::vianame("GREEK CAPITAL LETTER ETA");
- print "ok 44\n";
+ cmp_ok( 0x3093, '==', charnames::vianame("HIRAGANA LETTER N"));
+ cmp_ok(0x0397, '==', charnames::vianame("GREEK CAPITAL LETTER ETA"));
}
-print "not " if defined charnames::viacode(0x110000);
-print "ok 45\n";
-
-print "not " if grep { /you asked for U+110000/ } @WARN;
-print "ok 46\n";
+ok(! defined charnames::viacode(0x110000));
+ok(! grep { /you asked for U+110000/ } @WARN);
-print "not " unless "NULL" eq charnames::viacode(0);
-print "ok 47\n";
+is(charnames::viacode(0), "NULL");
+is(charnames::viacode("BE"), "VULGAR FRACTION THREE QUARTERS");
+is(charnames::viacode("U+00000000000FEED"), "ARABIC LETTER WAW ISOLATED FORM");
# ---- Alias extensions
my $alifile = File::Spec->catfile(File::Spec->updir, qw(lib unicore
xyzzy_alias.pl));
-my $i = 0;
my @prgs;
-{ local $/ = undef;
+{
+ local $/ = undef;
@prgs = split "\n########\n", <DATA>;
- }
+}
-my $i = 47;
for (@prgs) {
my ($code, $exp) = ((split m/\nEXPECT\n/), '$');
my ($prog, $fil) = ((split m/\nFILE\n/, $code), "");
@@ -281,8 +223,9 @@ for (@prgs) {
open my $ali, "> $alifile" or die "Could not open $alifile: $!";
print $ali $fil;
close $ali or die "Could not close $alifile: $!";
- }
- my $res = runperl( switches => $switch,
+ }
+ my $switch = "";
+ my $res = runperl( switches => $switch,
progfile => $tmpfile,
stderr => 1 );
my $status = $?;
@@ -293,57 +236,51 @@ for (@prgs) {
$exp =~ s/[\r\n]+$//;
my $pfx = ($res =~ s/^PREFIX\n//);
my $rexp = qr{^$exp};
- if ($res =~ s/^SKIPPED\n//) {
- print "$results\n";
- }
- elsif (($pfx and $res !~ /^\Q$expected/) or
- (!$pfx and $res !~ $rexp)) {
- print STDERR
- "PROG:\n$prog\n",
- "FILE:\n$fil",
- "EXPECTED:\n$exp\n",
- "GOT:\n$res\n";
- print "not ";
- }
- print "ok ", ++$i, "\n";
+ my $expected = ""; # Unsure why this is here, as was never initialized
+
+ SKIP: {
+ skip $res, 1, if $res =~ s/^SKIPPED\n//;
+ if (($pfx and $res !~ /^\Q$expected/) or
+ (!$pfx and $res !~ $rexp))
+ {
+ fail("PROG:\n$prog\nFILE:\n${fil}EXPECTED:\n$exp\nGOT:\n$res");
+ } else {
+ pass("");
+ }
+ }
$fil or next;
1 while unlink $alifile;
- }
+}
# [perl #30409] charnames.pm clobbers default variable
$_ = 'foobar';
eval "use charnames ':full';";
-print "not " unless $_ eq 'foobar';
-print "ok 75\n";
+is($_, 'foobar');
# Unicode slowdown noted by Phil Pennock, traced to a bug fix in index
# SADAHIRO Tomoyuki's suggestion is to ensure that the UTF-8ness of both
# arguments are indentical before calling index.
# To do this can take advantage of the fact that unicore/Name.pl is 7 bit
-# (or at least should be). So assert that that it's true here.
+# (or at least should be). So assert that that it's true here. EBCDIC
+# may be a problem (khw).
my $names = do "unicore/Name.pl";
-print defined $names ? "ok 76\n" : "not ok 76\n";
-if (ord('A') == 65) { # as on ASCII or UTF-8 machines
- my $non_ascii = $names =~ tr/\0-\177//c;
- print $non_ascii ? "not ok 77 # $non_ascii\n" : "ok 77\n";
-} else {
- print "ok 77\n";
-}
+ok(defined $names);
+my $non_ascii = native_to_latin1($names) =~ tr/\0-\177//c;
+ok(! $non_ascii, "Make sure all names are ASCII-only");
# Verify that charnames propagate to eval("")
my $evaltry = eval q[ "Eval: \N{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}" ];
if ($@) {
- print "# $...@not ok 78\nnot ok 79\n";
+ fail('charnames failed to propagate to eval("")');
+ fail('next test also fails to make the same number of tests');
} else {
- print "ok 78\n";
- print "not " unless $evaltry eq "Eval: \N{LEFT-POINTING DOUBLE ANGLE
QUOTATION MARK}";
- print "ok 79\n";
+ pass('charnames propagated to eval("")');
+ is($evaltry, "Eval: \N{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}");
}
# Verify that db includes the normative NameAliases.txt names
-print "not " unless "\N{U+1D0C5}" eq "\N{BYZANTINE MUSICAL SYMBOL FTHORA
SKLIRON CHROMA VASIS}";
-print "ok 80\n";
+is("\N{U+1D0C5}", "\N{BYZANTINE MUSICAL SYMBOL FTHORA SKLIRON CHROMA VASIS}");
# [perl #73174] use of \N{FOO} used to reset %^H
@@ -358,8 +295,7 @@ print "ok 80\n";
$res .= '-' . ($^H{73174} // "");
$res .= '-2' if ":" =~ /\N{COLON}/;
$res .= '-3' if ":" =~ /\N{COLON}/i;
- print $res eq "foo-foo-1--2-3" ? "" : "not ",
- "ok 81 - \$^H{foo} correct after /\\N{bar}/i (res=$res)\n";
+ is($res, "foo-foo-1--2-3");
}
__END__
--
Perl5 Master Repository
