Introduce NVef, NVff, and NVgf, use the middle one.
[perl.git] / lib / utf8_heavy.pl
1 package utf8;
2
3 my $DEBUG = 0;
4 my $seq = "AAA0000";
5
6 sub DESTROY {}
7
8 sub croak { require Carp; Carp::croak(@_) }
9
10 sub SWASHNEW {
11     my ($class, $type, $list, $minbits, $none) = @_;
12     local $^D = 0 if $^D;
13     print STDERR "SWASHNEW @_\n" if $DEBUG;
14     my $extras;
15     my $bits;
16  
17     if ($type and ref ${"${class}::{$type}"} eq $class) {
18         warn qq/Found \${"${class}::{$type}"}\n/ if $DEBUG;
19         return ${"${class}::{$type}"};  # Already there...
20     }
21
22     $type ||= $seq++;
23
24     my $caller;
25     my $i = 0;
26     while (($caller = caller($i)) eq __PACKAGE__) { $i++ }
27     my $encoding = $enc{$caller} || "unicode";
28     (my $file = $type) =~ s!::!/!g;
29     $file =~ s#^(I[sn]|To)([A-Z].*)#$1/$2#;
30     $list ||= eval { $caller->$type(); }
31         || do "$file.pl"
32         || do "$encoding/$file.pl"
33         || do "$encoding/Is/${type}.pl"
34         || croak("Can't find $encoding character property definition via $caller->$type or $file.pl");
35
36     $| = 1;
37
38     if ($list) {
39         my @tmp = split(/^/m, $list);
40         my %seen;
41         no warnings;
42         $extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
43         $list = join '',
44             sort { hex $a <=> hex $b }
45             grep {/^([0-9a-fA-F]+)/ and not $seen{$1}++} @tmp; # XXX doesn't do ranges right
46     }
47
48     if ($none) {
49         my $hextra = sprintf "%04x", $none + 1;
50         $list =~ s/\tXXXX$/\t$hextra/mg;
51     }
52
53     if ($minbits < 32) {
54         my $top = 0;
55         while ($list =~ /^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+)?)(?:\t([0-9a-fA-F]+))?/mg) {
56             my $min = hex $1;
57             my $max = hex(defined $2 ? $2 : $1);
58             my $val = hex(defined $3 ? $3 : "");
59             $val += $max - $min if defined $3;
60             $top = $val if $val > $top;
61         }
62         $bits =
63             $top > 0xffff ? 32 :
64             $top > 0xff ? 16 :
65             $top > 1 ? 8 : 1
66     }
67     $bits = $minbits if $bits < $minbits;
68
69     my @extras;
70     for my $x ($extras) {
71         pos $x = 0;
72         while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
73             my $char = $1;
74             my $name = $2;
75             # print STDERR "$1 => $2\n" if $DEBUG;
76             if ($char =~ /[-+!]/) {
77                 my ($c,$t) = split(/::/, $name, 2);     # bogus use of ::, really
78                 my $subobj = $c->SWASHNEW($t, "", 0, 0, 0);
79                 push @extras, $name => $subobj;
80                 $bits = $subobj->{BITS} if $bits < $subobj->{BITS};
81             }
82         }
83     }
84
85     print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if $DEBUG;
86
87     ${"${class}::{$type}"} = bless {
88         TYPE => $type,
89         BITS => $bits,
90         EXTRAS => $extras,
91         LIST => $list,
92         NONE => $none,
93         @extras,
94     } => $class;
95 }
96
97 # NOTE: utf8.c:swash_init() assumes entries are never modified once generated.
98
99 sub SWASHGET {
100     my ($self, $start, $len) = @_;
101     local $^D = 0 if $^D;
102     my $type = $self->{TYPE};
103     my $bits = $self->{BITS};
104     my $none = $self->{NONE};
105     print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if $DEBUG;
106     my $end = $start + $len;
107     my $swatch = "";
108     my $key;
109     vec($swatch, $len - 1, $bits) = 0;  # Extend to correct length.
110     if ($none) {
111         for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none }
112     }
113
114     for ($self->{LIST}) {
115         pos $_ = 0;
116         if ($bits > 1) {
117           LINE:
118             while (/^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+)?)(?:\t([0-9a-fA-F]+))?/mg) {
119                 my $min = hex $1;
120                 my $max = (defined $2 ? hex $2 : $min);
121                 my $val = hex $3;
122                 next if $max < $start;
123 #               print "$min $max $val\n";
124                 if ($none) {
125                     if ($min < $start) {
126                         $val += $start - $min if $val < $none;
127                         $min = $start;
128                     }
129                     for ($key = $min; $key <= $max; $key++) {
130                         last LINE if $key >= $end;
131 #                       print STDERR "$key => $val\n" if $DEBUG;
132                         vec($swatch, $key - $start, $bits) = $val;
133                         ++$val if $val < $none;
134                     }
135                 }
136                 else {
137                     if ($min < $start) {
138                         $val += $start - $min;
139                         $min = $start;
140                     }
141                     for ($key = $min; $key <= $max; $key++, $val++) {
142                         last LINE if $key >= $end;
143 #                       print STDERR "$key => $val\n" if $DEBUG;
144                         vec($swatch, $key - $start, $bits) = $val;
145                     }
146                 }
147             }
148         }
149         else {
150           LINE:
151             while (/^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+))?/mg) {
152                 my $min = hex $1;
153                 my $max = (defined $2 ? hex $2 : $min);
154                 next if $max < $start;
155                 if ($min < $start) {
156                     $min = $start;
157                 }
158                 for ($key = $min; $key <= $max; $key++) {
159                     last LINE if $key >= $end;
160 #                   print STDERR "$key => 1\n" if $DEBUG;
161                     vec($swatch, $key - $start, 1) = 1;
162                 }
163             }
164         }
165     }
166     for my $x ($self->{EXTRAS}) {
167         pos $x = 0;
168         while ($x =~ /^([-+!])(.*)/mg) {
169             my $char = $1;
170             my $name = $2;
171             print STDERR "INDIRECT $1 $2\n" if $DEBUG;
172             my $otherbits = $self->{$name}->{BITS};
173             croak("SWASHGET size mismatch") if $bits < $otherbits;
174             my $other = $self->{$name}->SWASHGET($start, $len);
175             if ($char eq '+') {
176                 if ($bits == 1 and $otherbits == 1) {
177                     $swatch |= $other;
178                 }
179                 else {
180                     for ($key = 0; $key < $len; $key++) {
181                         vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
182                     }
183                 }
184             }
185             elsif ($char eq '!') {
186                 if ($bits == 1 and $otherbits == 1) {
187                     $swatch |= ~$other;
188                 }
189                 else {
190                     for ($key = 0; $key < $len; $key++) {
191                         if (!vec($other, $key, $otherbits)) {
192                             vec($swatch, $key, $bits) = 1;
193                         }
194                     }
195                 }
196             }
197             elsif ($char eq '-') {
198                 if ($bits == 1 and $otherbits == 1) {
199                     $swatch &= ~$other;
200                 }
201                 else {
202                     for ($key = 0; $key < $len; $key++) {
203                         if (vec($other, $key, $otherbits)) {
204                             vec($swatch, $key, $bits) = 0;
205                         }
206                     }
207                 }
208             }
209         }
210     }
211     if ($DEBUG) {
212         print STDERR "CELLS ";
213         for ($key = 0; $key < $len; $key++) {
214             print STDERR vec($swatch, $key, $bits), " ";
215         }
216         print STDERR "\n";
217     }
218     $swatch;
219 }
220
221 1;