2 more VMS test tweaks

[perl5.git] / lib / utf8_heavy.pl

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index 5637d12..3efd421 100644 (file)
--- 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,38 +9,58 @@ 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} || "unicode";
-    (my $file = $type) =~ s!::!/!g;
-    if ($file =~ /^In(.+)/) {
-       defined %utf8::In || do "$encoding/In.pl";
-       if (exists $utf8::In{$1}) {
-           $file = "$enconding/In/$utf8::In{$1}";
+    if ($type) {
+
+       defined %utf8::In || do "unicore/In.pl";
+
+       $type =~ s/^In(?:[-_]|\s+)?(?!herited$)//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{$inprefix}->{$k};
+                   if (exists $utf8::In{$In}) {
+                       $file = "unicore/In/$utf8::In{$In}";
+                       print "inprefix = $inprefix, In = $In, k = $k, file = $file\n" if DEBUG;
+                       last;
+                   }
+               }
+           }
+       }
+
+       unless (defined $file) {
+           # This is separate from 'To' in preparation of Is.pl (a la In.pl).
+           if ($type =~ /^Is([A-Z][A-Za-z]*|L&)$/ || $type =~ /^(L&)$/ ) {
+               my $cat = $1 eq 'L&' ? 'L' : $1;
+               $file = "unicore/Is/$cat";
+           } elsif ((not defined $file) && $type =~ /^To([A-Z][A-Za-z]*)$/) {
+               $file = "unicore/To/$1";
+           }
        }
-    } else {
-       $file =~ s#^(Is|To)([A-Z].*)#$1/$2#;
     }
-    $list ||= eval { $caller->$type(); }
-       || do "$file.pl"
-       || do "$encoding/$file.pl"
-       || do "$encoding/Is/${type}.pl"
-       || croak("Can't find $encoding character property definition via $caller->$type or $file.pl");
 
-    $| = 1;
+    {
+        $list ||= do "$file.pl"
+             ||  do "unicore/Is/$type.pl"
+             ||  croak("Can't find Unicode character property \"$type\"");
+    }
 
+    my $extras;
+    my $bits;
+ 
     if ($list) {
        my @tmp = split(/^/m, $list);
        my %seen;
@@ -79,7 +98,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);
@@ -89,7 +108,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,
@@ -109,7 +128,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;
@@ -135,7 +154,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;
                    }
@@ -147,7 +166,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;
                    }
                }
@@ -164,7 +183,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;
                }
            }
@@ -175,7 +194,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);
@@ -215,7 +234,7 @@ sub SWASHGET {
            }
        }
     }
-    if ($DEBUG) {
+    if (DEBUG) {
        print STDERR "CELLS ";
        for ($key = 0; $key < $len; $key++) {
            print STDERR vec($swatch, $key, $bits), " ";