Cleanup utf8_heavy; allow dropping the In prefix from

Unicode script/block properties.

p4raw-id: //depot/perl@12281

1 files changed, 43 insertions, 41 deletions

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index ed3da176ac..3e145deb09 100644
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -1,7 +1,6 @@
 package utf8;
 
-my $DEBUG = 0;
-my $seq = "AAA0000";
+sub DEBUG () { 0 }
 
 sub DESTROY {}
 
@@ -10,53 +9,56 @@ sub croak { require Carp; Carp::croak(@_) }
 sub SWASHNEW {
     my ($class, $type, $list, $minbits, $none) = @_;
     local $^D = 0 if $^D;
-    print STDERR "SWASHNEW @_\n" if $DEBUG;
-    my $extras;
-    my $bits;
- 
+
+    print STDERR "SWASHNEW @_\n" if DEBUG;
+
+    my $file;
+
     if ($type and ref ${"${class}::{$type}"} eq $class) {
-	warn qq/Found \${"${class}::{$type}"}\n/ if $DEBUG;
+	warn qq/Found \${"${class}::{$type}"}\n/ if DEBUG;
 	return ${"${class}::{$type}"};	# Already there...
     }
 
-    $type ||= $seq++;
-
-    my $caller;
-    my $i = 0;
-    while (($caller = caller($i)) eq __PACKAGE__) { $i++ }
-    my $encoding = $enc{$caller} || "unicore";
-    (my $file = $type) =~ s!::!/!g;
-    if ($file =~ /^(?:In|in|IN|iN)[- _]?(.+?)\s*$/) { # /i would cause recursion.
-	my $In = $1;
-	defined %utf8::In || do "$encoding/In.pl";
-	my $prefix = substr(lc($In), 0, 3);
-	if (exists $utf8::InPat{$prefix}) {
-	    for my $k (keys %{$utf8::InPat{$prefix}}) {
+    if ($type) {
+
+	defined %utf8::In || do "unicore/In.pl";
+
+	$type =~ s/^In(?:[-_]|\s+)?//i;
+	$type =~ s/\s+$//;
+
+	my $inprefix = substr(lc($type), 0, 3);
+	if (exists $utf8::InPat{$inprefix}) {
+	    my $In = $type;
+	    for my $k (keys %{$utf8::InPat{$inprefix}}) {
 		if ($In =~ /^$k$/i) {
-		    $In = $utf8::InPat{$prefix}->{$k};
+		    $In = $utf8::InPat{$inprefix}->{$k};
 		    if (exists $utf8::In{$In}) {
-			$file = "$encoding/In/$utf8::In{$In}";
+			$file = "unicore/In/$utf8::In{$In}";
+			print "inprefix = $inprefix, In = $In, k = $k, file = $file\n" if DEBUG;
 			last;
 		    }
 		}
 	    }
 	}
-    } else {
-	$file =~ s#^(Is|To)([A-Z].*)#$1/$2#;
+
+	# This is separate from 'To' in preparation of Is.pl (a la In.pl).
+	if ((not defined $file) && $type =~ /^Is([A-Z][A-Za-z]*)$/) {
+	    $file = "unicore/Is/$1";
+	}
+
+	if ((not defined $file) && $type =~ /^To([A-Z][A-Za-z]*)$/) {
+	    $file = "unicore/To/$1";
+	}
     }
 
     {
-        $list ||=
-	    ( exists &{"${caller}::${type}"} &&
-	      eval { $caller->$type() } )
-	    || do "$file.pl"
-	    || do "$encoding/$file.pl"
-	    || do "$encoding/Is/${type}.pl"
-	    || croak("Can't find Unicode character property \"$type\"");
+        $list ||= do "$file.pl"
+	      ||  croak("Can't find Unicode character property \"$type\"");
     }
 
-    $| = 1;
-
+    my $extras;
+    my $bits;
+ 
     if ($list) {
 	my @tmp = split(/^/m, $list);
 	my %seen;
@@ -94,7 +96,7 @@ sub SWASHNEW {
 	while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
 	    my $char = $1;
 	    my $name = $2;
-	    # print STDERR "$1 => $2\n" if $DEBUG;
+#	    print STDERR "$1 => $2\n" if DEBUG;
 	    if ($char =~ /[-+!]/) {
 		my ($c,$t) = split(/::/, $name, 2);	# bogus use of ::, really
 		my $subobj = $c->SWASHNEW($t, "", 0, 0, 0);
@@ -104,7 +106,7 @@ sub SWASHNEW {
 	}
     }
 
-    print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if $DEBUG;
+    print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG;
 
     ${"${class}::{$type}"} = bless {
 	TYPE => $type,
@@ -124,7 +126,7 @@ sub SWASHGET {
     my $type = $self->{TYPE};
     my $bits = $self->{BITS};
     my $none = $self->{NONE};
-    print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if $DEBUG;
+    print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG;
     my $end = $start + $len;
     my $swatch = "";
     my $key;
@@ -150,7 +152,7 @@ sub SWASHGET {
 		    }
 		    for ($key = $min; $key <= $max; $key++) {
 			last LINE if $key >= $end;
-#			print STDERR "$key => $val\n" if $DEBUG;
+#			print STDERR "$key => $val\n" if DEBUG;
 			vec($swatch, $key - $start, $bits) = $val;
 			++$val if $val < $none;
 		    }
@@ -162,7 +164,7 @@ sub SWASHGET {
 		    }
 		    for ($key = $min; $key <= $max; $key++, $val++) {
 			last LINE if $key >= $end;
-#			print STDERR "$key => $val\n" if $DEBUG;
+#			print STDERR "$key => $val\n" if DEBUG;
 			vec($swatch, $key - $start, $bits) = $val;
 		    }
 		}
@@ -179,7 +181,7 @@ sub SWASHGET {
 		}
 		for ($key = $min; $key <= $max; $key++) {
 		    last LINE if $key >= $end;
-#		    print STDERR "$key => 1\n" if $DEBUG;
+#		    print STDERR "$key => 1\n" if DEBUG;
 		    vec($swatch, $key - $start, 1) = 1;
 		}
 	    }
@@ -190,7 +192,7 @@ sub SWASHGET {
 	while ($x =~ /^([-+!])(.*)/mg) {
 	    my $char = $1;
 	    my $name = $2;
-	    print STDERR "INDIRECT $1 $2\n" if $DEBUG;
+	    print STDERR "INDIRECT $1 $2\n" if DEBUG;
 	    my $otherbits = $self->{$name}->{BITS};
 	    croak("SWASHGET size mismatch") if $bits < $otherbits;
 	    my $other = $self->{$name}->SWASHGET($start, $len);
@@ -230,7 +232,7 @@ sub SWASHGET {
 	    }
 	}
     }
-    if ($DEBUG) {
+    if (DEBUG) {
 	print STDERR "CELLS ";
 	for ($key = 0; $key < $len; $key++) {
 	    print STDERR vec($swatch, $key, $bits), " ";