revised PATCH: [perl #74702], modernize charnames.t

>From aa2b63678e13cb3f2a46a8baba9b252f2f8cc81b Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@khw-desktop.(none)>
Date: Sat, 29 May 2010 13:25:43 -0600
Subject: [PATCH] Update charnames.t to modern style

This now uses test.pl to define subroutines that make it easier to
maintain.
---
 lib/charnames.t |  278 +++++++++++++++++++++----------------------------------
 1 files changed, 105 insertions(+), 173 deletions(-)

diff --git a/lib/charnames.t b/lib/charnames.t
index 144c826..f9bbdbc 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(83);
 
 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,145 @@ 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";
-
-print "not " unless "NULL" eq charnames::viacode(0);
-print "ok 47\n";
+ok(! defined charnames::viacode(0x110000));
+ok(! grep { /you asked for U+110000/ } @WARN);
 
+is("NULL", charnames::viacode(0));
 
 # ---- 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 +220,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,28 +233,26 @@ 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
@@ -323,27 +261,22 @@ print "ok 75\n";
 # (or at least should be). So assert that that it's true here.
 
 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 +291,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__
-- 
1.5.6.3

>From 2f9a5114203cc24f1cc903ef962efaa59186461c Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@khw-desktop.(none)>
Date: Sat, 29 May 2010 13:29:53 -0600
Subject: [PATCH] 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.
---
 lib/charnames.pm |    2 +-
 lib/charnames.t  |    7 +++++--
 2 files changed, 6 insertions(+), 3 deletions(-)

diff --git a/lib/charnames.pm b/lib/charnames.pm
index 2bf36ac..637c215 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;
diff --git a/lib/charnames.t b/lib/charnames.t
index f9bbdbc..9efd07a 100644
--- a/lib/charnames.t
+++ b/lib/charnames.t
@@ -16,7 +16,7 @@ require File::Spec;
 
 $| = 1;
 
-plan(83);
+plan(85);
 
 use charnames ':full';
 
@@ -196,7 +196,10 @@ is("\N{U+263A}", "\N{WHITE SMILING FACE}");
 ok(! defined charnames::viacode(0x110000));
 ok(! grep { /you asked for U+110000/ } @WARN);
 
-is("NULL", charnames::viacode(0));
+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
 
-- 
1.5.6.3

>From bca29dbdb5476ef68fcd26bf5798b9fba5746dc6 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@khw-desktop.(none)>
Date: Sat, 29 May 2010 13:34:55 -0600
Subject: [PATCH] Remove BUG report from pod that is now fixed

viacode now works correctly for 0.
---
 lib/charnames.pm |    2 --
 1 files changed, 0 insertions(+), 2 deletions(-)

diff --git a/lib/charnames.pm b/lib/charnames.pm
index 637c215..eddf66a 100644
--- a/lib/charnames.pm
+++ b/lib/charnames.pm
@@ -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.
 
-- 
1.5.6.3

>From bbfb578b737d428b045ae8ff0cda2a90c6fc9f51 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@khw-desktop.(none)>
Date: Sun, 30 May 2010 07:17:52 -0600
Subject: [PATCH] Add cautionary comment to .t

---
 lib/charnames.t |    3 ++-
 1 files changed, 2 insertions(+), 1 deletions(-)

diff --git a/lib/charnames.t b/lib/charnames.t
index 9efd07a..ce2bc34 100644
--- a/lib/charnames.t
+++ b/lib/charnames.t
@@ -261,7 +261,8 @@ is($_, 'foobar');
 # 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";
 ok(defined $names);
-- 
1.5.6.3