while (($caller = caller($i)) eq __PACKAGE__) { $i++ }
my $encoding = $enc{$caller} || "unicode";
(my $file = $type) =~ s!::!/!g;
- $file =~ s#^(I[sn]|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");
+ if ($file =~ /^In(.+)/) {
+ defined %utf8::In || do "$encoding/In.pl";
+ if (exists $utf8::In{$1}) {
+ $file = "$enconding/In/$utf8::In{$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 $encoding character property \"$type\"");
+ }
$| = 1;
if ($list) {
my @tmp = split(/^/m, $list);
my %seen;
- local $^W = 0;
+ no warnings;
$extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
$list = join '',
sort { hex $a <=> hex $b }
my @extras;
for my $x ($extras) {
pos $x = 0;
- while ($x =~ /^([^0-9a-fA-F])(.*)/mg) {
+ while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
my $char = $1;
my $name = $2;
# print STDERR "$1 => $2\n" if $DEBUG;
sub SWASHGET {
my ($self, $start, $len) = @_;
local $^D = 0 if $^D;
- print STDERR "SWASHGET @_\n" if $DEBUG;
my $type = $self->{TYPE};
my $bits = $self->{BITS};
my $none = $self->{NONE};
+ print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if $DEBUG;
my $end = $start + $len;
my $swatch = "";
my $key;
# print "$min $max $val\n";
if ($none) {
if ($min < $start) {
- $val += $start - $min;
- $val = $none if $val > $none;
+ $val += $start - $min if $val < $none;
$min = $start;
}
for ($key = $min; $key <= $max; $key++) {
}
for my $x ($self->{EXTRAS}) {
pos $x = 0;
- while ($x =~ /^([^0-9a-fA-F])(.*)/mg) {
+ while ($x =~ /^([-+!])(.*)/mg) {
my $char = $1;
my $name = $2;
print STDERR "INDIRECT $1 $2\n" if $DEBUG;
- if ($char =~ /^[-+!]$/) {
- my $otherbits = $self->{$name}->{BITS};
- croak("SWASHGET size mismatch") if $bits < $otherbits;
- my $other = $self->{$name}->SWASHGET($start, $len);
- if ($char eq '+') {
- if ($bits == 1 and $otherbits == 1) {
- $swatch |= $other;
- }
- else {
- for ($key = 0; $key < $len; $key++) {
- vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
- }
- }
+ my $otherbits = $self->{$name}->{BITS};
+ croak("SWASHGET size mismatch") if $bits < $otherbits;
+ my $other = $self->{$name}->SWASHGET($start, $len);
+ if ($char eq '+') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch |= $other;
}
- elsif ($char eq '!') {
- if ($bits == 1 and $otherbits == 1) {
- $swatch |= ~$other;
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
}
- else {
- for ($key = 0; $key < $len; $key++) {
- if (!vec($other, $key, $otherbits)) {
- vec($swatch, $key, $bits) = 1;
- }
+ }
+ }
+ elsif ($char eq '!') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch |= ~$other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ if (!vec($other, $key, $otherbits)) {
+ vec($swatch, $key, $bits) = 1;
}
}
}
- elsif ($char eq '-') {
- if ($bits == 1 and $otherbits == 1) {
- $swatch &= ~$other;
- }
- else {
- for ($key = 0; $key < $len; $key++) {
- if (vec($other, $key, $otherbits)) {
- vec($swatch, $key, $bits) = 0;
- }
+ }
+ elsif ($char eq '-') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch &= ~$other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ if (vec($other, $key, $otherbits)) {
+ vec($swatch, $key, $bits) = 0;
}
}
}