package utf8;
-my $DEBUG = 0;
-my $seq = "AAA0000";
+sub DEBUG () { 0 }
sub DESTROY {}
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;
+
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[- _]?(.+?)$/i) {
- 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 ($In =~ /^$k$/i) {
- $In = $utf8::InPat{$prefix}->{$k};
- if (exists $utf8::In{$In}) {
- $file = "$encoding/In/$utf8::In{$In}";
- last;
+ if ($type) {
+ $type =~ s/^\s+//;
+ $type =~ s/\s+$//;
+
+ print "type = $type\n" if DEBUG;
+
+ my $file;
+
+ unless (defined $file) {
+ defined %utf8::Is || do "unicore/Is.pl";
+ if ($type =~ /^(?:Is|Category\s*=\s*)?[- _]?([A-Z].*)$/i) {
+ my $istype = $1;
+ print "istype = $istype\n" if DEBUG;
+ unless ($list = do "unicore/Is/$istype.pl") {
+ if (exists $utf8::Is{$istype}) {
+ $file = "unicore/Is/$utf8::Is{$istype}";
+ } else {
+ my $isprefix = substr(lc($istype), 0, 2);
+ print "isprefix = $isprefix\n" if DEBUG;
+ if (exists $utf8::IsPat{$isprefix}) {
+ my $Is = $istype;
+ print "isprefix = $isprefix, Is = $Is\n" if DEBUG;
+ for my $k (keys %{$utf8::IsPat{$isprefix}}) {
+ print "isprefix = $isprefix, Is = $Is, k = $k\n" if DEBUG;
+ if ($Is =~ /^$k$/i) {
+ $file = "unicore/Is/$utf8::IsPat{$isprefix}->{$k}";
+ print "isprefix = $isprefix, Is = $Is, k = $k, file = $file\n" if DEBUG;
+ last;
+ }
+ }
+ }
}
}
}
+
+ unless (defined $file) {
+ defined %utf8::In || do "unicore/In.pl";
+ $type = 'Lampersand' if $type =~ /^(?:Is)?L&$/;
+ if ($type =~ /^(In|(?:Script|Block)\s*=\s*)?[- _]?(?!herited$)(.+)/i) {
+ my $incat = $1;
+ my $intype = $2;
+ print "incat = $incat, intype = $intype\n" if DEBUG;
+ if (exists $utf8::In{$intype}) {
+ $file = "unicore/In/$utf8::In{$intype}";
+ } else {
+ my $inprefix = substr(lc($intype), 0, 2);
+ print "inprefix = $inprefix\n" if DEBUG;
+ if (exists $utf8::InPat{$inprefix}) {
+ my $In = $intype;
+ print "inprefix = $inprefix, In = $In\n" if DEBUG;
+ for my $k (keys %{$utf8::InPat{$inprefix}}) {
+ print "inprefix = $inprefix, In = $In, k = $k\n" if DEBUG;
+ if ($In =~ /^$k$/i) {
+ my $i = $utf8::InPat{$inprefix}->{$k};
+ print "inprefix = $inprefix, In = $In, k = $k, i = $i\n" if DEBUG;
+ next if $incat =~ /^S/ &&
+ !exists $utf8::InScript{$i};
+ next if $incat =~ /^B/ &&
+ !exists $utf8::InBlock{$i};
+ $file = "unicore/In/$i";
+ print "inprefix = $inprefix, In = $In, k = $k, file = $file\n" if DEBUG;
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+
+ unless (defined $file) {
+ if ($type =~ /^To([A-Z][A-Za-z]+)$/) {
+ $file = "unicore/To/$1";
+ }
+ }
}
- } else {
- $file =~ s#^(Is|To)([A-Z].*)#$1/$2#;
- }
- {
- $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\"");
- }
+ if (defined $file) {
+ $list = do "$file.pl";
+ }
- $| = 1;
+ croak("Can't find Unicode character property \"$type\"")
+ unless $list;
+ }
+ my $extras;
+ my $bits;
+
if ($list) {
my @tmp = split(/^/m, $list);
my %seen;
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);
}
}
- 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,
# NOTE: utf8.c:swash_init() assumes entries are never modified once generated.
sub SWASHGET {
+ # See utf8.c:Perl_swash_fetch for problems with this interface.
my ($self, $start, $len) = @_;
local $^D = 0 if $^D;
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;
my $max = (defined $2 ? hex $2 : $min);
my $val = hex $3;
next if $max < $start;
-# print "$min $max $val\n";
+ print "$min $max $val\n" if DEBUG;
if ($none) {
if ($min < $start) {
$val += $start - $min if $val < $none;
}
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;
}
}
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;
}
}
}
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;
}
}
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);
}
}
}
- if ($DEBUG) {
+ if (DEBUG) {
print STDERR "CELLS ";
for ($key = 0; $key < $len; $key++) {
print STDERR vec($swatch, $key, $bits), " ";
projects / p5sagit/p5-mst-13.2.git / blobdiff