Add Ken Brown to AUTHORS
[perl.git] / regen / regcharclass.pl
1 #!perl
2 package CharClass::Matcher;
3 use strict;
4 use 5.008;
5 use warnings;
6 use warnings FATAL => 'all';
7 use Data::Dumper;
8 $Data::Dumper::Useqq= 1;
9 our $hex_fmt= "0x%02X";
10
11 sub DEBUG () { 0 }
12 $|=1 if DEBUG;
13
14 require './regen/regen_lib.pl';
15 require './regen/charset_translations.pl';
16 require "./regen/regcharclass_multi_char_folds.pl";
17
18 =head1 NAME
19
20 CharClass::Matcher -- Generate C macros that match character classes efficiently
21
22 =head1 SYNOPSIS
23
24     perl Porting/regcharclass.pl
25
26 =head1 DESCRIPTION
27
28 Dynamically generates macros for detecting special charclasses
29 in latin-1, utf8, and codepoint forms. Macros can be set to return
30 the length (in bytes) of the matched codepoint, and/or the codepoint itself.
31
32 To regenerate F<regcharclass.h>, run this script from perl-root. No arguments
33 are necessary.
34
35 Using WHATEVER as an example the following macros can be produced, depending
36 on the input parameters (how to get each is described by internal comments at
37 the C<__DATA__> line):
38
39 =over 4
40
41 =item C<is_WHATEVER(s,is_utf8)>
42
43 =item C<is_WHATEVER_safe(s,e,is_utf8)>
44
45 Do a lookup as appropriate based on the C<is_utf8> flag. When possible
46 comparisons involving octect<128 are done before checking the C<is_utf8>
47 flag, hopefully saving time.
48
49 The version without the C<_safe> suffix should be used only when the input is
50 known to be well-formed.
51
52 =item C<is_WHATEVER_utf8(s)>
53
54 =item C<is_WHATEVER_utf8_safe(s,e)>
55
56 Do a lookup assuming the string is encoded in (normalized) UTF8.
57
58 The version without the C<_safe> suffix should be used only when the input is
59 known to be well-formed.
60
61 =item C<is_WHATEVER_latin1(s)>
62
63 =item C<is_WHATEVER_latin1_safe(s,e)>
64
65 Do a lookup assuming the string is encoded in latin-1 (aka plan octets).
66
67 The version without the C<_safe> suffix should be used only when it is known
68 that C<s> contains at least one character.
69
70 =item C<is_WHATEVER_cp(cp)>
71
72 Check to see if the string matches a given codepoint (hypothetically a
73 U32). The condition is constructed as to "break out" as early as
74 possible if the codepoint is out of range of the condition.
75
76 IOW:
77
78   (cp==X || (cp>X && (cp==Y || (cp>Y && ...))))
79
80 Thus if the character is X+1 only two comparisons will be done. Making
81 matching lookups slower, but non-matching faster.
82
83 =item C<what_len_WHATEVER_FOO(arg1, ..., len)>
84
85 A variant form of each of the macro types described above can be generated, in
86 which the code point is returned by the macro, and an extra parameter (in the
87 final position) is added, which is a pointer for the macro to set the byte
88 length of the returned code point.
89
90 These forms all have a C<what_len> prefix instead of the C<is_>, for example
91 C<what_len_WHATEVER_safe(s,e,is_utf8,len)> and
92 C<what_len_WHATEVER_utf8(s,len)>.
93
94 These forms should not be used I<except> on small sets of mostly widely
95 separated code points; otherwise the code generated is inefficient.  For these
96 cases, it is best to use the C<is_> forms, and then find the code point with
97 C<utf8_to_uvchr_buf>().  This program can fail with a "deep recursion"
98 message on the worst of the inappropriate sets.  Examine the generated macro
99 to see if it is acceptable.
100
101 =item C<what_WHATEVER_FOO(arg1, ...)>
102
103 A variant form of each of the C<is_> macro types described above can be generated, in
104 which the code point and not the length is returned by the macro.  These have
105 the same caveat as L</what_len_WHATEVER_FOO(arg1, ..., len)>, plus they should
106 not be used where the set contains a NULL, as 0 is returned for two different
107 cases: a) the set doesn't include the input code point; b) the set does
108 include it, and it is a NULL.
109
110 =back
111
112 The above isn't quite complete, as for specialized purposes one can get a
113 macro like C<is_WHATEVER_utf8_no_length_checks(s)>, which assumes that it is
114 already known that there is enough space to hold the character starting at
115 C<s>, but otherwise checks that it is well-formed.  In other words, this is
116 intermediary in checking between C<is_WHATEVER_utf8(s)> and
117 C<is_WHATEVER_utf8_safe(s,e)>.
118
119 =head2 CODE FORMAT
120
121 perltidy  -st -bt=1 -bbt=0 -pt=0 -sbt=1 -ce -nwls== "%f"
122
123
124 =head1 AUTHOR
125
126 Author: Yves Orton (demerphq) 2007.  Maintained by Perl5 Porters.
127
128 =head1 BUGS
129
130 No tests directly here (although the regex engine will fail tests
131 if this code is broken). Insufficient documentation and no Getopts
132 handler for using the module as a script.
133
134 =head1 LICENSE
135
136 You may distribute under the terms of either the GNU General Public
137 License or the Artistic License, as specified in the README file.
138
139 =cut
140
141 # Sub naming convention:
142 # __func : private subroutine, can not be called as a method
143 # _func  : private method, not meant for external use
144 # func   : public method.
145
146 # private subs
147 #-------------------------------------------------------------------------------
148 #
149 # ($cp,$n,$l,$u)=__uni_latin($str);
150 #
151 # Return a list of arrays, each of which when interpreted correctly
152 # represent the string in some given encoding with specific conditions.
153 #
154 # $cp - list of codepoints that make up the string.
155 # $n  - list of octets that make up the string if all codepoints are invariant
156 #       regardless of if the string is in UTF-8 or not.
157 # $l  - list of octets that make up the string in latin1 encoding if all
158 #       codepoints < 256, and at least one codepoint is UTF-8 variant.
159 # $u  - list of octets that make up the string in utf8 if any codepoint is
160 #       UTF-8 variant
161 #
162 #   High CP | Defined
163 #-----------+----------
164 #   0 - 127 : $n            (127/128 are the values for ASCII platforms)
165 # 128 - 255 : $l, $u
166 # 256 - ... : $u
167 #
168
169 sub __uni_latin1 {
170     my $charset= shift;
171     my $str= shift;
172     my $max= 0;
173     my @cp;
174     my @cp_high;
175     my $only_has_invariants = 1;
176     my $a2n = get_a2n($charset);
177     for my $ch ( split //, $str ) {
178         my $cp= ord $ch;
179         $max= $cp if $max < $cp;
180         if ($cp > 255) {
181             push @cp, $cp;
182             push @cp_high, $cp;
183         }
184         else {
185             push @cp, $a2n->[$cp];
186         }
187     }
188     my ( $n, $l, $u );
189     $only_has_invariants = ($charset =~ /ascii/i) ? $max < 128 : $max < 160;
190     if ($only_has_invariants) {
191         $n= [@cp];
192     } else {
193         $l= [@cp] if $max && $max < 256;
194
195         my @u;
196         for my $ch ( split //, $str ) {
197             push @u, map { ord } split //, cp_2_utfbytes(ord $ch, $charset);
198         }
199         $u = \@u;
200     }
201     return ( \@cp, \@cp_high, $n, $l, $u );
202 }
203
204 #
205 # $clean= __clean($expr);
206 #
207 # Cleanup a ternary expression, removing unnecessary parens and apply some
208 # simplifications using regexes.
209 #
210
211 sub __clean {
212     my ( $expr )= @_;
213
214     #return $expr;
215
216     our $parens;
217     $parens= qr/ (?> \( (?> (?: (?> [^()]+ ) | (??{ $parens }) )* ) \) ) /x;
218
219     ## remove redundant parens
220     1 while $expr =~ s/ \( \s* ( $parens ) \s* \) /$1/gx;
221
222
223     # repeatedly simplify conditions like
224     #       ( (cond1) ? ( (cond2) ? X : Y ) : Y )
225     # into
226     #       ( ( (cond1) && (cond2) ) ? X : Y )
227     # Also similarly handles expressions like:
228     #       : (cond1) ? ( (cond2) ? X : Y ) : Y )
229     # Note the inclusion of the close paren in ([:()]) and the open paren in ([()]) is
230     # purely to ensure we have a balanced set of parens in the expression which makes
231     # it easier to understand the pattern in an editor that understands paren's, we do
232     # not expect either of these cases to actually fire. - Yves
233     1 while $expr =~ s/
234         ([:()])  \s*
235             ($parens) \s*
236             \? \s*
237                 \( \s* ($parens) \s*
238                     \? \s* ($parens|[^()?:\s]+?) \s*
239                     :  \s* ($parens|[^()?:\s]+?) \s*
240                 \) \s*
241             : \s* \5 \s*
242         ([()])
243     /$1 ( $2 && $3 ) ? $4 : $5 $6/gx;
244     #$expr=~s/\(\(U8\*\)s\)\[(\d+)\]/S$1/g if length $expr > 8000;
245     #$expr=~s/\s+//g if length $expr > 8000;
246
247     die "Expression too long" if length $expr > 8000;
248
249     return $expr;
250 }
251
252 #
253 # $text= __macro(@args);
254 # Join args together by newlines, and then neatly add backslashes to the end
255 # of every  line as expected by the C pre-processor for #define's.
256 #
257
258 sub __macro {
259     my $str= join "\n", @_;
260     $str =~ s/\s*$//;
261     my @lines= map { s/\s+$//; s/\t/        /g; $_ } split /\n/, $str;
262     my $last= pop @lines;
263     $str= join "\n", ( map { sprintf "%-76s\\", $_ } @lines ), $last;
264     1 while $str =~ s/^(\t*) {8}/$1\t/gm;
265     return $str . "\n";
266 }
267
268 #
269 # my $op=__incrdepth($op);
270 #
271 # take an 'op' hashref and add one to it and all its childrens depths.
272 #
273
274 sub __incrdepth {
275     my $op= shift;
276     return unless ref $op;
277     $op->{depth} += 1;
278     __incrdepth( $op->{yes} );
279     __incrdepth( $op->{no} );
280     return $op;
281 }
282
283 # join two branches of an opcode together with a condition, incrementing
284 # the depth on the yes branch when we do so.
285 # returns the new root opcode of the tree.
286 sub __cond_join {
287     my ( $cond, $yes, $no )= @_;
288     if (ref $yes) {
289         return {
290             test  => $cond,
291             yes   => __incrdepth( $yes ),
292             no    => $no,
293             depth => 0,
294         };
295     }
296     else {
297         return {
298             test  => $cond,
299             yes   => $yes,
300             no    => __incrdepth($no),
301             depth => 0,
302         };
303     }
304 }
305
306 # Methods
307
308 # constructor
309 #
310 # my $obj=CLASS->new(op=>'SOMENAME',title=>'blah',txt=>[..]);
311 #
312 # Create a new CharClass::Matcher object by parsing the text in
313 # the txt array. Currently applies the following rules:
314 #
315 # Element starts with C<0x>, line is evaled the result treated as
316 # a number which is passed to chr().
317 #
318 # Element starts with C<">, line is evaled and the result treated
319 # as a string.
320 #
321 # Each string is then stored in the 'strs' subhash as a hash record
322 # made up of the results of __uni_latin1, using the keynames
323 # 'low','latin1','utf8', as well as the synthesized 'LATIN1', 'high', and
324 # 'UTF8' which hold a merge of 'low' and their lowercase equivalents.
325 #
326 # Size data is tracked per type in the 'size' subhash.
327 #
328 # Return an object
329 #
330 sub new {
331     my $class= shift;
332     my %opt= @_;
333     for ( qw(op txt) ) {
334         die "in " . __PACKAGE__ . " constructor '$_;' is a mandatory field"
335           if !exists $opt{$_};
336     }
337
338     my $self= bless {
339         op    => $opt{op},
340         title => $opt{title} || '',
341     }, $class;
342     foreach my $txt ( @{ $opt{txt} } ) {
343         my $str= $txt;
344         if ( $str =~ /^[""]/ ) {
345             $str= eval $str;
346         } elsif ($str =~ / - /x ) { # A range:  Replace this element on the
347                                     # list with its expansion
348             my ($lower, $upper) = $str =~ / 0x (.+?) \s* - \s* 0x (.+) /x;
349             die "Format must be like '0xDEAD - 0xBEAF'; instead was '$str'" if ! defined $lower || ! defined $upper;
350             foreach my $cp (hex $lower .. hex $upper) {
351                 push @{$opt{txt}}, sprintf "0x%X", $cp;
352             }
353             next;
354         } elsif ($str =~ s/ ^ N (?= 0x ) //x ) {
355             # Otherwise undocumented, a leading N means is already in the
356             # native character set; don't convert.
357             $str= chr eval $str;
358         } elsif ( $str =~ /^0x/ ) {
359             $str= eval $str;
360             $str = chr $str;
361         } elsif ( $str =~ / \s* \\p \{ ( .*? ) \} /x) {
362             my $property = $1;
363             use Unicode::UCD qw(prop_invlist);
364
365             my @invlist = prop_invlist($property, '_perl_core_internal_ok');
366             if (! @invlist) {
367
368                 # An empty return could mean an unknown property, or merely
369                 # that it is empty.  Call in scalar context to differentiate
370                 my $count = prop_invlist($property, '_perl_core_internal_ok');
371                 die "$property not found" unless defined $count;
372             }
373
374             # Replace this element on the list with the property's expansion
375             for (my $i = 0; $i < @invlist; $i += 2) {
376                 foreach my $cp ($invlist[$i] .. $invlist[$i+1] - 1) {
377
378                     # prop_invlist() returns native values; add leading 'N'
379                     # to indicate that.
380                     push @{$opt{txt}}, sprintf "N0x%X", $cp;
381                 }
382             }
383             next;
384         } elsif ($str =~ / ^ do \s+ ( .* ) /x) {
385             die "do '$1' failed: $!$@" if ! do $1 or $@;
386             next;
387         } elsif ($str =~ / ^ & \s* ( .* ) /x) { # user-furnished sub() call
388             my @results = eval "$1";
389             die "eval '$1' failed: $@" if $@;
390             push @{$opt{txt}}, @results;
391             next;
392         } else {
393             die "Unparsable line: $txt\n";
394         }
395         my ( $cp, $cp_high, $low, $latin1, $utf8 )= __uni_latin1( $opt{charset}, $str );
396         my $UTF8= $low   || $utf8;
397         my $LATIN1= $low || $latin1;
398         my $high = (scalar grep { $_ < 256 } @$cp) ? 0 : $utf8;
399         #die Dumper($txt,$cp,$low,$latin1,$utf8)
400         #    if $txt=~/NEL/ or $utf8 and @$utf8>3;
401
402         @{ $self->{strs}{$str} }{qw( str txt low utf8 latin1 high cp cp_high UTF8 LATIN1 )}=
403           ( $str, $txt, $low, $utf8, $latin1, $high, $cp, $cp_high, $UTF8, $LATIN1 );
404         my $rec= $self->{strs}{$str};
405         foreach my $key ( qw(low utf8 latin1 high cp cp_high UTF8 LATIN1) ) {
406             $self->{size}{$key}{ 0 + @{ $self->{strs}{$str}{$key} } }++
407               if $self->{strs}{$str}{$key};
408         }
409         $self->{has_multi} ||= @$cp > 1;
410         $self->{has_ascii} ||= $latin1 && @$latin1;
411         $self->{has_low}   ||= $low && @$low;
412         $self->{has_high}  ||= !$low && !$latin1;
413     }
414     $self->{val_fmt}= $hex_fmt;
415     $self->{count}= 0 + keys %{ $self->{strs} };
416     return $self;
417 }
418
419 # my $trie = make_trie($type,$maxlen);
420 #
421 # using the data stored in the object build a trie of a specific type,
422 # and with specific maximum depth. The trie is made up the elements of
423 # the given types array for each string in the object (assuming it is
424 # not too long.)
425 #
426 # returns the trie, or undef if there was no relevant data in the object.
427 #
428
429 sub make_trie {
430     my ( $self, $type, $maxlen )= @_;
431
432     my $strs= $self->{strs};
433     my %trie;
434     foreach my $rec ( values %$strs ) {
435         die "panic: unknown type '$type'"
436           if !exists $rec->{$type};
437         my $dat= $rec->{$type};
438         next unless $dat;
439         next if $maxlen && @$dat > $maxlen;
440         my $node= \%trie;
441         foreach my $elem ( @$dat ) {
442             $node->{$elem} ||= {};
443             $node= $node->{$elem};
444         }
445         $node->{''}= $rec->{str};
446     }
447     return 0 + keys( %trie ) ? \%trie : undef;
448 }
449
450 sub pop_count ($) {
451     my $word = shift;
452
453     # This returns a list of the positions of the bits in the input word that
454     # are 1.
455
456     my @positions;
457     my $position = 0;
458     while ($word) {
459         push @positions, $position if $word & 1;
460         $position++;
461         $word >>= 1;
462     }
463     return @positions;
464 }
465
466 # my $optree= _optree()
467 #
468 # recursively convert a trie to an optree where every node represents
469 # an if else branch.
470 #
471 #
472
473 sub _optree {
474     my ( $self, $trie, $test_type, $ret_type, $else, $depth )= @_;
475     return unless defined $trie;
476     if ( $self->{has_multi} and $ret_type =~ /cp|both/ ) {
477         die "Can't do 'cp' optree from multi-codepoint strings";
478     }
479     $ret_type ||= 'len';
480     $else= 0  unless defined $else;
481     $depth= 0 unless defined $depth;
482
483     # if we have an empty string as a key it means we are in an
484     # accepting state and unless we can match further on should
485     # return the value of the '' key.
486     if (exists $trie->{''} ) {
487         # we can now update the "else" value, anything failing to match
488         # after this point should return the value from this.
489         if ( $ret_type eq 'cp' ) {
490             $else= $self->{strs}{ $trie->{''} }{cp}[0];
491             $else= sprintf "$self->{val_fmt}", $else if $else > 9;
492         } elsif ( $ret_type eq 'len' ) {
493             $else= $depth;
494         } elsif ( $ret_type eq 'both') {
495             $else= $self->{strs}{ $trie->{''} }{cp}[0];
496             $else= sprintf "$self->{val_fmt}", $else if $else > 9;
497             $else= "len=$depth, $else";
498         }
499     }
500     # extract the meaningful keys from the trie, filter out '' as
501     # it means we are an accepting state (end of sequence).
502     my @conds= sort { $a <=> $b } grep { length $_ } keys %$trie;
503
504     # if we haven't any keys there is no further we can match and we
505     # can return the "else" value.
506     return $else if !@conds;
507
508     my $test = $test_type =~ /^cp/ ? "cp" : "((const U8*)s)[$depth]";
509
510     # First we loop over the possible keys/conditions and find out what they
511     # look like; we group conditions with the same optree together.
512     my %dmp_res;
513     my @res_order;
514     local $Data::Dumper::Sortkeys=1;
515     foreach my $cond ( @conds ) {
516
517         # get the optree for this child/condition
518         my $res= $self->_optree( $trie->{$cond}, $test_type, $ret_type, $else, $depth + 1 );
519         # convert it to a string with Dumper
520         my $res_code= Dumper( $res );
521
522         push @{$dmp_res{$res_code}{vals}}, $cond;
523         if (!$dmp_res{$res_code}{optree}) {
524             $dmp_res{$res_code}{optree}= $res;
525             push @res_order, $res_code;
526         }
527     }
528
529     # now that we have deduped the optrees we construct a new optree containing the merged
530     # results.
531     my %root;
532     my $node= \%root;
533     foreach my $res_code_idx (0 .. $#res_order) {
534         my $res_code= $res_order[$res_code_idx];
535         $node->{vals}= $dmp_res{$res_code}{vals};
536         $node->{test}= $test;
537         $node->{yes}= $dmp_res{$res_code}{optree};
538         $node->{depth}= $depth;
539         if ($res_code_idx < $#res_order) {
540             $node= $node->{no}= {};
541         } else {
542             $node->{no}= $else;
543         }
544     }
545
546     # return the optree.
547     return \%root;
548 }
549
550 # my $optree= optree(%opts);
551 #
552 # Convert a trie to an optree, wrapper for _optree
553
554 sub optree {
555     my $self= shift;
556     my %opt= @_;
557     my $trie= $self->make_trie( $opt{type}, $opt{max_depth} );
558     $opt{ret_type} ||= 'len';
559     my $test_type= $opt{type} =~ /^cp/ ? 'cp' : 'depth';
560     return $self->_optree( $trie, $test_type, $opt{ret_type}, $opt{else}, 0 );
561 }
562
563 # my $optree= generic_optree(%opts);
564 #
565 # build a "generic" optree out of the three 'low', 'latin1', 'utf8'
566 # sets of strings, including a branch for handling the string type check.
567 #
568
569 sub generic_optree {
570     my $self= shift;
571     my %opt= @_;
572
573     $opt{ret_type} ||= 'len';
574     my $test_type= 'depth';
575     my $else= $opt{else} || 0;
576
577     my $latin1= $self->make_trie( 'latin1', $opt{max_depth} );
578     my $utf8= $self->make_trie( 'utf8',     $opt{max_depth} );
579
580     $_= $self->_optree( $_, $test_type, $opt{ret_type}, $else, 0 )
581       for $latin1, $utf8;
582
583     if ( $utf8 ) {
584         $else= __cond_join( "( is_utf8 )", $utf8, $latin1 || $else );
585     } elsif ( $latin1 ) {
586         $else= __cond_join( "!( is_utf8 )", $latin1, $else );
587     }
588     if ($opt{type} eq 'generic') {
589         my $low= $self->make_trie( 'low', $opt{max_depth} );
590         if ( $low ) {
591             $else= $self->_optree( $low, $test_type, $opt{ret_type}, $else, 0 );
592         }
593     }
594
595     return $else;
596 }
597
598 # length_optree()
599 #
600 # create a string length guarded optree.
601 #
602
603 sub length_optree {
604     my $self= shift;
605     my %opt= @_;
606     my $type= $opt{type};
607
608     die "Can't do a length_optree on type 'cp', makes no sense."
609       if $type =~ /^cp/;
610
611     my $else= ( $opt{else} ||= 0 );
612
613     return $else if $self->{count} == 0;
614
615     my $method = $type =~ /generic/ ? 'generic_optree' : 'optree';
616     if ($method eq 'optree' && scalar keys %{$self->{size}{$type}} == 1) {
617
618         # Here is non-generic output (meaning that we are only generating one
619         # type), and all things that match have the same number ('size') of
620         # bytes.  The length guard is simply that we have that number of
621         # bytes.
622         my @size = keys %{$self->{size}{$type}};
623         my $cond= "((e) - (s)) >= $size[0]";
624         my $optree = $self->$method(%opt);
625         $else= __cond_join( $cond, $optree, $else );
626     }
627     elsif ($self->{has_multi}) {
628         my @size;
629
630         # Here, there can be a match of a multiple character string.  We use
631         # the traditional method which is to have a branch for each possible
632         # size (longest first) and test for the legal values for that size.
633         my %sizes= (
634             %{ $self->{size}{low}    || {} },
635             %{ $self->{size}{latin1} || {} },
636             %{ $self->{size}{utf8}   || {} }
637         );
638         if ($method eq 'generic_optree') {
639             @size= sort { $a <=> $b } keys %sizes;
640         } else {
641             @size= sort { $a <=> $b } keys %{ $self->{size}{$type} };
642         }
643         for my $size ( @size ) {
644             my $optree= $self->$method( %opt, type => $type, max_depth => $size );
645             my $cond= "((e)-(s) > " . ( $size - 1 ).")";
646             $else= __cond_join( $cond, $optree, $else );
647         }
648     }
649     else {
650         my $utf8;
651
652         # Here, has more than one possible size, and only matches a single
653         # character.  For non-utf8, the needed length is 1; for utf8, it is
654         # found by array lookup 'UTF8SKIP'.
655
656         # If want just the code points above 255, set up to look for those;
657         # otherwise assume will be looking for all non-UTF-8-invariant code
658         # poiints.
659         my $trie_type = ($type eq 'high') ? 'high' : 'utf8';
660
661         # If we do want more than the 0-255 range, find those, and if they
662         # exist...
663         if ($opt{type} !~ /latin1/i && ($utf8 = $self->make_trie($trie_type, 0))) {
664
665             # ... get them into an optree, and set them up as the 'else' clause
666             $utf8 = $self->_optree( $utf8, 'depth', $opt{ret_type}, 0, 0 );
667
668             # We could make this
669             #   UTF8_IS_START(*s) && ((e) - (s)) >= UTF8SKIP(s))";
670             # to avoid doing the UTF8SKIP and subsequent branches for invariants
671             # that don't match.  But the current macros that get generated
672             # have only a few things that can match past this, so I (khw)
673             # don't think it is worth it.  (Even better would be to use
674             # calculate_mask(keys %$utf8) instead of UTF8_IS_START, and use it
675             # if it saves a bunch.  We assume that input text likely to be
676             # well-formed .
677             my $cond = "LIKELY(((e) - (s)) >= UTF8SKIP(s))";
678             $else = __cond_join($cond, $utf8, $else);
679
680             # For 'generic', we also will want the latin1 UTF-8 variants for
681             # the case where the input isn't UTF-8.
682             my $latin1;
683             if ($method eq 'generic_optree') {
684                 $latin1 = $self->make_trie( 'latin1', 1);
685                 $latin1= $self->_optree( $latin1, 'depth', $opt{ret_type}, 0, 0 );
686             }
687
688             # If we want the UTF-8 invariants, get those.
689             my $low;
690             if ($opt{type} !~ /non_low|high/
691                 && ($low= $self->make_trie( 'low', 1)))
692             {
693                 $low= $self->_optree( $low, 'depth', $opt{ret_type}, 0, 0 );
694
695                 # Expand out the UTF-8 invariants as a string so that we
696                 # can use them as the conditional
697                 $low = $self->_cond_as_str( $low, 0, \%opt);
698
699                 # If there are Latin1 variants, add a test for them.
700                 if ($latin1) {
701                     $else = __cond_join("(! is_utf8 )", $latin1, $else);
702                 }
703                 elsif ($method eq 'generic_optree') {
704
705                     # Otherwise for 'generic' only we know that what
706                     # follows must be valid for just UTF-8 strings,
707                     $else->{test} = "( is_utf8 && $else->{test} )";
708                 }
709
710                 # If the invariants match, we are done; otherwise we have
711                 # to go to the 'else' clause.
712                 $else = __cond_join($low, 1, $else);
713             }
714             elsif ($latin1) {   # Here, didn't want or didn't have invariants,
715                                 # but we do have latin variants
716                 $else = __cond_join("(! is_utf8)", $latin1, $else);
717             }
718
719             # We need at least one byte available to start off the tests
720             $else = __cond_join("LIKELY((e) > (s))", $else, 0);
721         }
722         else {  # Here, we don't want or there aren't any variants.  A single
723                 # byte available is enough.
724             my $cond= "((e) > (s))";
725             my $optree = $self->$method(%opt);
726             $else= __cond_join( $cond, $optree, $else );
727         }
728     }
729
730     return $else;
731 }
732
733 sub calculate_mask(@) {
734     # Look at the input list of byte values.  This routine returns an array of
735     # mask/base pairs to generate that list.
736
737     my @list = @_;
738     my $list_count = @list;
739
740     # Consider a set of byte values, A, B, C ....  If we want to determine if
741     # <c> is one of them, we can write c==A || c==B || c==C ....  If the
742     # values are consecutive, we can shorten that to A<=c && c<=Z, which uses
743     # far fewer branches.  If only some of them are consecutive we can still
744     # save some branches by creating range tests for just those that are
745     # consecutive. _cond_as_str() does this work for looking for ranges.
746     #
747     # Another approach is to look at the bit patterns for A, B, C .... and see
748     # if they have some commonalities.  That's what this function does.  For
749     # example, consider a set consisting of the bytes
750     # 0xF0, 0xF1, 0xF2, and 0xF3.  We could write:
751     #   0xF0 <= c && c <= 0xF4
752     # But the following mask/compare also works, and has just one test:
753     #   (c & 0xFC) == 0xF0
754     # The reason it works is that the set consists of exactly those bytes
755     # whose first 4 bits are 1, and the next two are 0.  (The value of the
756     # other 2 bits is immaterial in determining if a byte is in the set or
757     # not.)  The mask masks out those 2 irrelevant bits, and the comparison
758     # makes sure that the result matches all bytes which match those 6
759     # material bits exactly.  In other words, the set of bytes contains
760     # exactly those whose bottom two bit positions are either 0 or 1.  The
761     # same principle applies to bit positions that are not necessarily
762     # adjacent.  And it can be applied to bytes that differ in 1 through all 8
763     # bit positions.  In order to be a candidate for this optimization, the
764     # number of bytes in the set must be a power of 2.
765     #
766     # Consider a different example, the set 0x53, 0x54, 0x73, and 0x74.  That
767     # requires 4 tests using either ranges or individual values, and even
768     # though the number in the set is a power of 2, it doesn't qualify for the
769     # mask optimization described above because the number of bits that are
770     # different is too large for that.  However, the set can be expressed as
771     # two branches with masks thusly:
772     #   (c & 0xDF) == 0x53 || (c & 0xDF) == 0x54
773     # a branch savings of 50%.  This is done by splitting the set into two
774     # subsets each of which has 2 elements, and within each set the values
775     # differ by 1 byte.
776     #
777     # This function attempts to find some way to save some branches using the
778     # mask technique.  If not, it returns an empty list; if so, it
779     # returns a list consisting of
780     #   [ [compare1, mask1], [compare2, mask2], ...
781     #     [compare_n, undef], [compare_m, undef], ...
782     #   ]
783     # The <mask> is undef in the above for those bytes that must be tested
784     # for individually.
785     #
786     # This function does not attempt to find the optimal set.  To do so would
787     # probably require testing all possible combinations, and keeping track of
788     # the current best one.
789     #
790     # There are probably much better algorithms, but this is the one I (khw)
791     # came up with.  We start with doing a bit-wise compare of every byte in
792     # the set with every other byte.  The results are sorted into arrays of
793     # all those that differ by the same bit positions.  These are stored in a
794     # hash with the each key being the bits they differ in.  Here is the hash
795     # for the 0x53, 0x54, 0x73, 0x74 set:
796     # {
797     #    4 => {
798     #            "0,1,2,5" => [
799     #                            83,
800     #                            116,
801     #                            84,
802     #                            115
803     #                        ]
804     #        },
805     #    3 => {
806     #            "0,1,2" => [
807     #                        83,
808     #                        84,
809     #                        115,
810     #                        116
811     #                        ]
812     #        }
813     #    1 => {
814     #            5 => [
815     #                    83,
816     #                    115,
817     #                    84,
818     #                    116
819     #                ]
820     #        },
821     # }
822     #
823     # The set consisting of values which differ in the 4 bit positions 0, 1,
824     # 2, and 5 from some other value in the set consists of all 4 values.
825     # Likewise all 4 values differ from some other value in the 3 bit
826     # positions 0, 1, and 2; and all 4 values differ from some other value in
827     # the single bit position 5.  The keys at the uppermost level in the above
828     # hash, 1, 3, and 4, give the number of bit positions that each sub-key
829     # below it has.  For example, the 4 key could have as its value an array
830     # consisting of "0,1,2,5", "0,1,2,6", and "3,4,6,7", if the inputs were
831     # such.  The best optimization will group the most values into a single
832     # mask.  The most values will be the ones that differ in the most
833     # positions, the ones with the largest value for the topmost key.  These
834     # keys, are thus just for convenience of sorting by that number, and do
835     # not have any bearing on the core of the algorithm.
836     #
837     # We start with an element from largest number of differing bits.  The
838     # largest in this case is 4 bits, and there is only one situation in this
839     # set which has 4 differing bits, "0,1,2,5".  We look for any subset of
840     # this set which has 16 values that differ in these 4 bits.  There aren't
841     # any, because there are only 4 values in the entire set.  We then look at
842     # the next possible thing, which is 3 bits differing in positions "0,1,2".
843     # We look for a subset that has 8 values that differ in these 3 bits.
844     # Again there are none.  So we go to look for the next possible thing,
845     # which is a subset of 2**1 values that differ only in bit position 5.  83
846     # and 115 do, so we calculate a mask and base for those and remove them
847     # from every set.  Since there is only the one set remaining, we remove
848     # them from just this one.  We then look to see if there is another set of
849     # 2 values that differ in bit position 5.  84 and 116 do, so we calculate
850     # a mask and base for those and remove them from every set (again only
851     # this set remains in this example).  The set is now empty, and there are
852     # no more sets to look at, so we are done.
853
854     if ($list_count == 256) {   # All 256 is trivially masked
855         return (0, 0);
856     }
857
858     my %hash;
859
860     # Generate bits-differing lists for each element compared against each
861     # other element
862     for my $i (0 .. $list_count - 2) {
863         for my $j ($i + 1 .. $list_count - 1) {
864             my @bits_that_differ = pop_count($list[$i] ^ $list[$j]);
865             my $differ_count = @bits_that_differ;
866             my $key = join ",", @bits_that_differ;
867             push @{$hash{$differ_count}{$key}}, $list[$i] unless grep { $_ == $list[$i] } @{$hash{$differ_count}{$key}};
868             push @{$hash{$differ_count}{$key}}, $list[$j];
869         }
870     }
871
872     print STDERR __LINE__, ": calculate_mask() called:  List of values grouped by differing bits: ", Dumper \%hash if DEBUG;
873
874     my @final_results;
875     foreach my $count (reverse sort { $a <=> $b } keys %hash) {
876         my $need = 2 ** $count;     # Need 8 values for 3 differing bits, etc
877         foreach my $bits (sort keys $hash{$count}->%*) {
878
879             print STDERR __LINE__, ": For $count bit(s) difference ($bits), need $need; have ", scalar @{$hash{$count}{$bits}}, "\n" if DEBUG;
880
881             # Look only as long as there are at least as many elements in the
882             # subset as are needed
883             while ((my $cur_count = @{$hash{$count}{$bits}}) >= $need) {
884
885                 print STDERR __LINE__, ": Looking at bit positions ($bits): ", Dumper $hash{$count}{$bits} if DEBUG;
886
887                 # Start with the first element in it
888                 my $try_base = $hash{$count}{$bits}[0];
889                 my @subset = $try_base;
890
891                 # If it succeeds, we return a mask and a base to compare
892                 # against the masked value.  That base will be the AND of
893                 # every element in the subset.  Initialize to the one element
894                 # we have so far.
895                 my $compare = $try_base;
896
897                 # We are trying to find a subset of this that has <need>
898                 # elements that differ in the bit positions given by the
899                 # string $bits, which is comma separated.
900                 my @bits = split ",", $bits;
901
902                 TRY: # Look through the remainder of the list for other
903                      # elements that differ only by these bit positions.
904
905                 for (my $i = 1; $i < $cur_count; $i++) {
906                     my $try_this = $hash{$count}{$bits}[$i];
907                     my @positions = pop_count($try_base ^ $try_this);
908
909                     print STDERR __LINE__, ": $try_base vs $try_this: is (", join(',', @positions), ") a subset of ($bits)?" if DEBUG;;
910
911                     foreach my $pos (@positions) {
912                         unless (grep { $pos == $_ } @bits) {
913                             print STDERR "  No\n" if DEBUG;
914                             my $remaining = $cur_count - $i - 1;
915                             if ($remaining && @subset + $remaining < $need) {
916                                 print STDERR __LINE__, ": Can stop trying $try_base, because even if all the remaining $remaining values work, they wouldn't add up to the needed $need when combined with the existing ", scalar @subset, " ones\n" if DEBUG;
917                                 last TRY;
918                             }
919                             next TRY;
920                         }
921                     }
922
923                     print STDERR "  Yes\n" if DEBUG;
924                     push @subset, $try_this;
925
926                     # Add this to the mask base, in case it ultimately
927                     # succeeds,
928                     $compare &= $try_this;
929                 }
930
931                 print STDERR __LINE__, ": subset (", join(", ", @subset), ") has ", scalar @subset, " elements; needs $need\n" if DEBUG;
932
933                 if (@subset < $need) {
934                     shift @{$hash{$count}{$bits}};
935                     next;   # Try with next value
936                 }
937
938                 # Create the mask
939                 my $mask = 0;
940                 foreach my $position (@bits) {
941                     $mask |= 1 << $position;
942                 }
943                 $mask = ~$mask & 0xFF;
944                 push @final_results, [$compare, $mask];
945
946                 printf STDERR "%d: Got it: compare=%d=0x%X; mask=%X\n", __LINE__, $compare, $compare, $mask if DEBUG;
947
948                 # These values are now spoken for.  Remove them from future
949                 # consideration
950                 foreach my $remove_count (sort keys %hash) {
951                     foreach my $bits (sort keys %{$hash{$remove_count}}) {
952                         foreach my $to_remove (@subset) {
953                             @{$hash{$remove_count}{$bits}} = grep { $_ != $to_remove } @{$hash{$remove_count}{$bits}};
954                         }
955                     }
956                 }
957             }
958         }
959     }
960
961     # Any values that remain in the list are ones that have to be tested for
962     # individually.
963     my @individuals;
964     foreach my $count (reverse sort { $a <=> $b } keys %hash) {
965         foreach my $bits (sort keys $hash{$count}->%*) {
966             foreach my $remaining (@{$hash{$count}{$bits}}) {
967
968                 # If we already know about this value, just ignore it.
969                 next if grep { $remaining == $_ } @individuals;
970
971                 # Otherwise it needs to be returned as something to match
972                 # individually
973                 push @final_results, [$remaining, undef];
974                 push @individuals, $remaining;
975             }
976         }
977     }
978
979     # Sort by increasing numeric value
980     @final_results = sort { $a->[0] <=> $b->[0] } @final_results;
981
982     print STDERR __LINE__, ": Final return: ", Dumper \@final_results if DEBUG;
983
984     return @final_results;
985 }
986
987 # _cond_as_str
988 # turn a list of conditions into a text expression
989 # - merges ranges of conditions, and joins the result with ||
990 sub _cond_as_str {
991     my ( $self, $op, $combine, $opts_ref )= @_;
992     my $cond= $op->{vals};
993     my $test= $op->{test};
994     my $is_cp_ret = $opts_ref->{ret_type} eq "cp";
995     return "( $test )" if !defined $cond;
996
997     # rangify the list.
998     my @ranges;
999     my $Update= sub {
1000         # We skip this if there are optimizations that
1001         # we can apply (below) to the individual ranges
1002         if ( ($is_cp_ret || $combine) && @ranges && ref $ranges[-1]) {
1003             if ( $ranges[-1][0] == $ranges[-1][1] ) {
1004                 $ranges[-1]= $ranges[-1][0];
1005             } elsif ( $ranges[-1][0] + 1 == $ranges[-1][1] ) {
1006                 $ranges[-1]= $ranges[-1][0];
1007                 push @ranges, $ranges[-1] + 1;
1008             }
1009         }
1010     };
1011     for my $condition ( @$cond ) {
1012         if ( !@ranges || $condition != $ranges[-1][1] + 1 ) {
1013             $Update->();
1014             push @ranges, [ $condition, $condition ];
1015         } else {
1016             $ranges[-1][1]++;
1017         }
1018     }
1019     $Update->();
1020
1021     return $self->_combine( $test, @ranges )
1022       if $combine;
1023
1024     if ($is_cp_ret) {
1025         @ranges= map {
1026             ref $_
1027             ? sprintf(
1028                 "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
1029                 @$_ )
1030             : sprintf( "$self->{val_fmt} == $test", $_ );
1031         } @ranges;
1032
1033         return "( " . join( " || ", @ranges ) . " )";
1034     }
1035
1036     # If the input set has certain characteristics, we can optimize tests
1037     # for it.  This doesn't apply if returning the code point, as we want
1038     # each element of the set individually.  The code above is for this
1039     # simpler case.
1040
1041     return 1 if @$cond == 256;  # If all bytes match, is trivially true
1042
1043     my @masks;
1044     if (@ranges > 1) {
1045
1046         # See if the entire set shares optimizable characteristics, and if so,
1047         # return the optimization.  We delay checking for this on sets with
1048         # just a single range, as there may be better optimizations available
1049         # in that case.
1050         @masks = calculate_mask(@$cond);
1051
1052         # Stringify the output of calculate_mask()
1053         if (@masks) {
1054             my @return;
1055             foreach my $mask_ref (@masks) {
1056                 if (defined $mask_ref->[1]) {
1057                     push @return, sprintf "( ( $test & $self->{val_fmt} ) == $self->{val_fmt} )", $mask_ref->[1], $mask_ref->[0];
1058                 }
1059                 else {  # An undefined mask means to use the value as-is
1060                     push @return, sprintf "$test == $self->{val_fmt}", $mask_ref->[0];
1061                 }
1062             }
1063
1064             # The best possible case below for specifying this set of values via
1065             # ranges is 1 branch per range.  If our mask method yielded better
1066             # results, there is no sense trying something that is bound to be
1067             # worse.
1068             if (@return < @ranges) {
1069                 return "( " . join( " || ", @return ) . " )";
1070             }
1071
1072             @masks = @return;
1073         }
1074     }
1075
1076     # Here, there was no entire-class optimization that was clearly better
1077     # than doing things by ranges.  Look at each range.
1078     my $range_count_extra = 0;
1079     for (my $i = 0; $i < @ranges; $i++) {
1080         if (! ref $ranges[$i]) {    # Trivial case: no range
1081             $ranges[$i] = sprintf "$self->{val_fmt} == $test", $ranges[$i];
1082         }
1083         elsif ($ranges[$i]->[0] == $ranges[$i]->[1]) {
1084             $ranges[$i] =           # Trivial case: single element range
1085                     sprintf "$self->{val_fmt} == $test", $ranges[$i]->[0];
1086         }
1087         elsif ($ranges[$i]->[0] == 0) {
1088             # If the range matches all 256 possible bytes, it is trivially
1089             # true.
1090             return 1 if $ranges[0]->[1] == 0xFF;    # @ranges must be 1 in
1091                                                     # this case
1092             $ranges[$i] = sprintf "( $test <= $self->{val_fmt} )",
1093                                                                $ranges[$i]->[1];
1094         }
1095         elsif ($ranges[$i]->[1] == 255) {
1096
1097             # Similarly the max possible is 255, so can omit an upper bound
1098             # test if the calculated max is the max possible one.
1099             $ranges[$i] = sprintf "( $test >= $self->{val_fmt} )",
1100                                                                 $ranges[0]->[0];
1101         }
1102         else {
1103             my $output = "";
1104
1105             # Well-formed UTF-8 continuation bytes on ascii platforms must be
1106             # in the range 0x80 .. 0xBF.  If we know that the input is
1107             # well-formed (indicated by not trying to be 'safe'), we can omit
1108             # tests that verify that the input is within either of these
1109             # bounds.  (No legal UTF-8 character can begin with anything in
1110             # this range, so we don't have to worry about this being a
1111             # continuation byte or not.)
1112             if ($opts_ref->{charset} =~ /ascii/i
1113                 && (! $opts_ref->{safe} && ! $opts_ref->{no_length_checks})
1114                 && $opts_ref->{type} =~ / ^ (?: utf8 | high ) $ /xi)
1115             {
1116                 my $lower_limit_is_80 = ($ranges[$i]->[0] == 0x80);
1117                 my $upper_limit_is_BF = ($ranges[$i]->[1] == 0xBF);
1118
1119                 # If the range is the entire legal range, it matches any legal
1120                 # byte, so we can omit both tests.  (This should happen only
1121                 # if the number of ranges is 1.)
1122                 if ($lower_limit_is_80 && $upper_limit_is_BF) {
1123                     return 1;
1124                 }
1125                 elsif ($lower_limit_is_80) { # Just use the upper limit test
1126                     $output = sprintf("( $test <= $self->{val_fmt} )",
1127                                         $ranges[$i]->[1]);
1128                 }
1129                 elsif ($upper_limit_is_BF) { # Just use the lower limit test
1130                     $output = sprintf("( $test >= $self->{val_fmt} )",
1131                                     $ranges[$i]->[0]);
1132                 }
1133             }
1134
1135             # If we didn't change to omit a test above, see if the number of
1136             # elements is a power of 2 (only a single bit in the
1137             # representation of its count will be set) and if so, it may be
1138             # that a mask/compare optimization is possible.
1139             if ($output eq ""
1140                 && pop_count($ranges[$i]->[1] - $ranges[$i]->[0] + 1) == 1)
1141             {
1142                 my @list;
1143                 push @list, $_  for ($ranges[$i]->[0] .. $ranges[$i]->[1]);
1144                 my @this_masks = calculate_mask(@list);
1145
1146                 # Use the mask if there is just one for the whole range.
1147                 # Otherwise there is no savings over the two branches that can
1148                 # define the range.
1149                 if (@this_masks == 1 && defined $this_masks[0][1]) {
1150                     $output = sprintf "( $test & $self->{val_fmt} ) == $self->{val_fmt}", $this_masks[0][1], $this_masks[0][0];
1151                 }
1152             }
1153
1154             if ($output ne "") {  # Prefer any optimization
1155                 $ranges[$i] = $output;
1156             }
1157             else {
1158                 # No optimization happened.  We need a test that the code
1159                 # point is within both bounds.  But, if the bounds are
1160                 # adjacent code points, it is cleaner to say
1161                 # 'first == test || second == test'
1162                 # than it is to say
1163                 # 'first <= test && test <= second'
1164
1165                 $range_count_extra++;   # This range requires 2 branches to
1166                                         # represent
1167                 if ($ranges[$i]->[0] + 1 == $ranges[$i]->[1]) {
1168                     $ranges[$i] = "( "
1169                                 .  join( " || ", ( map
1170                                     { sprintf "$self->{val_fmt} == $test", $_ }
1171                                     @{$ranges[$i]} ) )
1172                                 . " )";
1173                 }
1174                 else {  # Full bounds checking
1175                     $ranges[$i] = sprintf("( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )", $ranges[$i]->[0], $ranges[$i]->[1]);
1176                 }
1177             }
1178         }
1179     }
1180
1181     # We have generated the list of bytes in two ways; one trying to use masks
1182     # to cut the number of branches down, and the other to look at individual
1183     # ranges (some of which could be cut down by using a mask for just it).
1184     # We return whichever method uses the fewest branches.
1185     return "( "
1186            . join( " || ", (@masks && @masks < @ranges + $range_count_extra)
1187                             ? @masks
1188                             : @ranges)
1189            . " )";
1190 }
1191
1192 # _combine
1193 # recursively turn a list of conditions into a fast break-out condition
1194 # used by _cond_as_str() for 'cp' type macros.
1195 sub _combine {
1196     my ( $self, $test, @cond )= @_;
1197     return if !@cond;
1198     my $item= shift @cond;
1199     my ( $cstr, $gtv );
1200     if ( ref $item ) {  # @item should be a 2-element array giving range start
1201                         # and end
1202         if ($item->[0] == 0) {  # UV's are never negative, so skip "0 <= "
1203                                 # test which could generate a compiler warning
1204                                 # that test is always true
1205             $cstr= sprintf( "$test <= $self->{val_fmt}", $item->[1] );
1206         }
1207         else {
1208             $cstr=
1209           sprintf( "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
1210                    @$item );
1211         }
1212         $gtv= sprintf "$self->{val_fmt}", $item->[1];
1213     } else {
1214         $cstr= sprintf( "$self->{val_fmt} == $test", $item );
1215         $gtv= sprintf "$self->{val_fmt}", $item;
1216     }
1217     if ( @cond ) {
1218         my $combine= $self->_combine( $test, @cond );
1219         if (@cond >1) {
1220             return "( $cstr || ( $gtv < $test &&\n"
1221                    . $combine . " ) )";
1222         } else {
1223             return "( $cstr || $combine )";
1224         }
1225     } else {
1226         return $cstr;
1227     }
1228 }
1229
1230 # _render()
1231 # recursively convert an optree to text with reasonably neat formatting
1232 sub _render {
1233     my ( $self, $op, $combine, $brace, $opts_ref, $def, $submacros )= @_;
1234     return 0 if ! defined $op;  # The set is empty
1235     if ( !ref $op ) {
1236         return $op;
1237     }
1238     my $cond= $self->_cond_as_str( $op, $combine, $opts_ref );
1239     #no warnings 'recursion';   # This would allow really really inefficient
1240                                 # code to be generated.  See pod
1241     my $yes= $self->_render( $op->{yes}, $combine, 1, $opts_ref, $def, $submacros );
1242     return $yes if $cond eq '1';
1243
1244     my $no= $self->_render( $op->{no},   $combine, 0, $opts_ref, $def, $submacros );
1245     return "( $cond )" if $yes eq '1' and $no eq '0';
1246     my ( $lb, $rb )= $brace ? ( "( ", " )" ) : ( "", "" );
1247     return "$lb$cond ? $yes : $no$rb"
1248       if !ref( $op->{yes} ) && !ref( $op->{no} );
1249     my $ind1= " " x 4;
1250     my $ind= "\n" . ( $ind1 x $op->{depth} );
1251
1252     if ( ref $op->{yes} ) {
1253         $yes= $ind . $ind1 . $yes;
1254     } else {
1255         $yes= " " . $yes;
1256     }
1257
1258     my $str= "$lb$cond ?$yes$ind: $no$rb";
1259     if (length $str > 6000) {
1260         push @$submacros, sprintf "#define $def\n( %s )", "_part" . (my $yes_idx= 0+@$submacros), $yes;
1261         push @$submacros, sprintf "#define $def\n( %s )", "_part" . (my $no_idx= 0+@$submacros), $no;
1262         return sprintf "%s%s ? $def : $def%s", $lb, $cond, "_part$yes_idx", "_part$no_idx", $rb;
1263     }
1264     return $str;
1265 }
1266
1267 # $expr=render($op,$combine)
1268 #
1269 # convert an optree to text with reasonably neat formatting. If $combine
1270 # is true then the condition is created using "fast breakouts" which
1271 # produce uglier expressions that are more efficient for common case,
1272 # longer lists such as that resulting from type 'cp' output.
1273 # Currently only used for type 'cp' macros.
1274 sub render {
1275     my ( $self, $op, $combine, $opts_ref, $def_fmt )= @_;
1276     
1277     my @submacros;
1278     my $macro= sprintf "#define $def_fmt\n( %s )", "", $self->_render( $op, $combine, 0, $opts_ref, $def_fmt, \@submacros );
1279
1280     return join "\n\n", map { "/*** GENERATED CODE ***/\n" . __macro( __clean( $_ ) ) } @submacros, $macro;
1281 }
1282
1283 # make_macro
1284 # make a macro of a given type.
1285 # calls into make_trie and (generic_|length_)optree as needed
1286 # Opts are:
1287 # type             : 'cp','cp_high', 'generic','high','low','latin1','utf8','LATIN1','UTF8'
1288 # ret_type         : 'cp' or 'len'
1289 # safe             : don't assume is well-formed UTF-8, so don't skip any range
1290 #                    checks, and add length guards to macro
1291 # no_length_checks : like safe, but don't add length guards.
1292 #
1293 # type defaults to 'generic', and ret_type to 'len' unless type is 'cp'
1294 # in which case it defaults to 'cp' as well.
1295 #
1296 # It is illegal to do a type 'cp' macro on a pattern with multi-codepoint
1297 # sequences in it, as the generated macro will accept only a single codepoint
1298 # as an argument.
1299 #
1300 # It is also illegal to do a non-safe macro on a pattern with multi-codepoint
1301 # sequences in it, as even if it is known to be well-formed, we need to not
1302 # run off the end of the buffer when, say, the buffer ends with the first two
1303 # characters, but three are looked at by the macro.
1304 #
1305 # returns the macro.
1306
1307
1308 sub make_macro {
1309     my $self= shift;
1310     my %opts= @_;
1311     my $type= $opts{type} || 'generic';
1312     if ($self->{has_multi}) {
1313         if ($type =~ /^cp/) {
1314             die "Can't do a 'cp' on multi-codepoint character class '$self->{op}'"
1315         }
1316         elsif (! $opts{safe}) {
1317             die "'safe' is required on multi-codepoint character class '$self->{op}'"
1318         }
1319     }
1320     my $ret_type= $opts{ret_type} || ( $opts{type} =~ /^cp/ ? 'cp' : 'len' );
1321     my $method;
1322     if ( $opts{safe} ) {
1323         $method= 'length_optree';
1324     } elsif ( $type =~ /generic/ ) {
1325         $method= 'generic_optree';
1326     } else {
1327         $method= 'optree';
1328     }
1329     my @args= $type =~ /^cp/ ? 'cp' : 's';
1330     push @args, "e" if $opts{safe};
1331     push @args, "is_utf8" if $type =~ /generic/;
1332     push @args, "len" if $ret_type eq 'both';
1333     my $pfx= $ret_type eq 'both'    ? 'what_len_' : 
1334              $ret_type eq 'cp'      ? 'what_'     : 'is_';
1335     my $ext= $type     =~ /generic/ ? ''          : '_' . lc( $type );
1336     $ext .= '_non_low' if $type eq 'generic_non_low';
1337     $ext .= "_safe" if $opts{safe};
1338     $ext .= "_no_length_checks" if $opts{no_length_checks};
1339     my $argstr= join ",", @args;
1340     my $def_fmt="$pfx$self->{op}$ext%s($argstr)";
1341     my $optree= $self->$method( %opts, type => $type, ret_type => $ret_type );
1342     return $self->render( $optree, ($type =~ /^cp/) ? 1 : 0, \%opts, $def_fmt );
1343 }
1344
1345 # if we aren't being used as a module (highly likely) then process
1346 # the __DATA__ below and produce macros in regcharclass.h
1347 # if an argument is provided to the script then it is assumed to
1348 # be the path of the file to output to, if the arg is '-' outputs
1349 # to STDOUT.
1350 if ( !caller ) {
1351     $|++;
1352     my $path= shift @ARGV || "regcharclass.h";
1353     my $out_fh;
1354     if ( $path eq '-' ) {
1355         $out_fh= \*STDOUT;
1356     } else {
1357         $out_fh = open_new( $path );
1358     }
1359     print $out_fh read_only_top( lang => 'C', by => $0,
1360                                  file => 'regcharclass.h', style => '*',
1361                                  copyright => [2007, 2011],
1362                                  final => <<EOF,
1363 WARNING: These macros are for internal Perl core use only, and may be
1364 changed or removed without notice.
1365 EOF
1366     );
1367     print $out_fh "\n#ifndef PERL_REGCHARCLASS_H_ /* Guard against nested #includes */\n#define PERL_REGCHARCLASS_H_\n";
1368
1369     my ( $op, $title, @txt, @types, %mods );
1370     my $doit= sub ($) {
1371         return unless $op;
1372
1373         my $charset = shift;
1374
1375         # Skip if to compile on a different platform.
1376         return if delete $mods{only_ascii_platform} && $charset !~ /ascii/i;
1377         return if delete $mods{only_ebcdic_platform} && $charset !~ /ebcdic/i;
1378
1379         print $out_fh "/*\n\t$op: $title\n\n";
1380         print $out_fh join "\n", ( map { "\t$_" } @txt ), "*/", "";
1381         my $obj= __PACKAGE__->new( op => $op, title => $title, txt => \@txt, charset => $charset);
1382
1383         #die Dumper(\@types,\%mods);
1384
1385         my @mods;
1386         push @mods, 'safe' if delete $mods{safe};
1387         push @mods, 'no_length_checks' if delete $mods{no_length_checks};
1388         unshift @mods, 'fast' if delete $mods{fast} || ! @mods; # Default to 'fast'
1389                                                                 # do this one
1390                                                                 # first, as
1391                                                                 # traditional
1392         if (%mods) {
1393             die "Unknown modifiers: ", join ", ", map { "'$_'" } sort keys %mods;
1394         }
1395
1396         foreach my $type_spec ( @types ) {
1397             my ( $type, $ret )= split /-/, $type_spec;
1398             $ret ||= 'len';
1399             foreach my $mod ( @mods ) {
1400
1401                 # 'safe' is irrelevant with code point macros, so skip if
1402                 # there is also a 'fast', but don't skip if this is the only
1403                 # way a cp macro will get generated.  Below we convert 'safe'
1404                 # to 'fast' in this instance
1405                 next if $type =~ /^cp/
1406                         && ($mod eq 'safe' || $mod eq 'no_length_checks')
1407                         && grep { 'fast' =~ $_ } @mods;
1408                 delete $mods{$mod};
1409                 my $macro= $obj->make_macro(
1410                     type     => $type,
1411                     ret_type => $ret,
1412                     safe     => $mod eq 'safe' && $type !~ /^cp/,
1413                     charset  => $charset,
1414                     no_length_checks => $mod eq 'no_length_checks' && $type !~ /^cp/,
1415                 );
1416                 print $out_fh $macro, "\n";
1417             }
1418         }
1419     };
1420
1421     my @data = <DATA>;
1422     foreach my $charset (get_supported_code_pages()) {
1423         my $first_time = 1;
1424         undef $op;
1425         undef $title;
1426         undef @txt;
1427         undef @types;
1428         undef %mods;
1429         print $out_fh "\n", get_conditional_compile_line_start($charset);
1430         my @data_copy = @data;
1431         for (@data_copy) {
1432             s/^ \s* (?: \# .* ) ? $ //x;    # squeeze out comment and blanks
1433             next unless /\S/;
1434             chomp;
1435             if ( /^[A-Z]/ ) {
1436                 $doit->($charset) unless $first_time;  # This starts a new
1437                                                        # definition; do the
1438                                                        # previous one
1439                 $first_time = 0;
1440                 ( $op, $title )= split /\s*:\s*/, $_, 2;
1441                 @txt= ();
1442             } elsif ( s/^=>// ) {
1443                 my ( $type, $modifier )= split /:/, $_;
1444                 @types= split ' ', $type;
1445                 undef %mods;
1446                 map { $mods{$_} = 1 } split ' ',  $modifier;
1447             } else {
1448                 push @txt, "$_";
1449             }
1450         }
1451         $doit->($charset);
1452         print $out_fh get_conditional_compile_line_end();
1453     }
1454
1455     print $out_fh "\n#endif /* PERL_REGCHARCLASS_H_ */\n";
1456
1457     if($path eq '-') {
1458         print $out_fh "/* ex: set ro: */\n";
1459     } else {
1460         # Some of the sources for these macros come from Unicode tables
1461         my $sources_list = "lib/unicore/mktables.lst";
1462         my @sources = ($0, qw(lib/unicore/mktables
1463                               lib/Unicode/UCD.pm
1464                               regen/regcharclass_multi_char_folds.pl
1465                               regen/charset_translations.pl
1466                              ));
1467         {
1468             # Depend on mktables’ own sources.  It’s a shorter list of files than
1469             # those that Unicode::UCD uses.
1470             if (! open my $mktables_list, '<', $sources_list) {
1471
1472                 # This should force a rebuild once $sources_list exists
1473                 push @sources, $sources_list;
1474             }
1475             else {
1476                 while(<$mktables_list>) {
1477                     last if /===/;
1478                     chomp;
1479                     push @sources, "lib/unicore/$_" if /^[^#]/;
1480                 }
1481             }
1482         }
1483         read_only_bottom_close_and_rename($out_fh, \@sources)
1484     }
1485 }
1486
1487 # The form of the input is a series of definitions to make macros for.
1488 # The first line gives the base name of the macro, followed by a colon, and
1489 # then text to be used in comments associated with the macro that are its
1490 # title or description.  In all cases the first (perhaps only) parameter to
1491 # the macro is a pointer to the first byte of the code point it is to test to
1492 # see if it is in the class determined by the macro.  In the case of non-UTF8,
1493 # the code point consists only of a single byte.
1494 #
1495 # The second line must begin with a '=>' and be followed by the types of
1496 # macro(s) to be generated; these are specified below.  A colon follows the
1497 # types, followed by the modifiers, also specified below.  At least one
1498 # modifier is required.
1499 #
1500 # The subsequent lines give what code points go into the class defined by the
1501 # macro.  Multiple characters may be specified via a string like "\x0D\x0A",
1502 # enclosed in quotes.  Otherwise the lines consist of one of:
1503 #   1)  a single Unicode code point, prefaced by 0x
1504 #   2)  a single range of Unicode code points separated by a minus (and
1505 #       optional space)
1506 #   3)  a single Unicode property specified in the standard Perl form
1507 #       "\p{...}"
1508 #   4)  a line like 'do path'.  This will do a 'do' on the file given by
1509 #       'path'.  It is assumed that this does nothing but load subroutines
1510 #       (See item 5 below).  The reason 'require path' is not used instead is
1511 #       because 'do' doesn't assume that path is in @INC.
1512 #   5)  a subroutine call
1513 #           &pkg::foo(arg1, ...)
1514 #       where pkg::foo was loaded by a 'do' line (item 4).  The subroutine
1515 #       returns an array of entries of forms like items 1-3 above.  This
1516 #       allows more complex inputs than achievable from the other input types.
1517 #
1518 # A blank line or one whose first non-blank character is '#' is a comment.
1519 # The definition of the macro is terminated by a line unlike those described.
1520 #
1521 # Valid types:
1522 #   low         generate a macro whose name is 'is_BASE_low' and defines a
1523 #               class that includes only ASCII-range chars.  (BASE is the
1524 #               input macro base name.)
1525 #   latin1      generate a macro whose name is 'is_BASE_latin1' and defines a
1526 #               class that includes only upper-Latin1-range chars.  It is not
1527 #               designed to take a UTF-8 input parameter.
1528 #   high        generate a macro whose name is 'is_BASE_high' and defines a
1529 #               class that includes all relevant code points that are above
1530 #               the Latin1 range.  This is for very specialized uses only.
1531 #               It is designed to take only an input UTF-8 parameter.
1532 #   utf8        generate a macro whose name is 'is_BASE_utf8' and defines a
1533 #               class that includes all relevant characters that aren't ASCII.
1534 #               It is designed to take only an input UTF-8 parameter.
1535 #   LATIN1      generate a macro whose name is 'is_BASE_latin1' and defines a
1536 #               class that includes both ASCII and upper-Latin1-range chars.
1537 #               It is not designed to take a UTF-8 input parameter.
1538 #   UTF8        generate a macro whose name is 'is_BASE_utf8' and defines a
1539 #               class that can include any code point, adding the 'low' ones
1540 #               to what 'utf8' works on.  It is designed to take only an input
1541 #               UTF-8 parameter.
1542 #   generic     generate a macro whose name is 'is_BASE".  It has a 2nd,
1543 #               boolean, parameter which indicates if the first one points to
1544 #               a UTF-8 string or not.  Thus it works in all circumstances.
1545 #   generic_non_low generate a macro whose name is 'is_BASE_non_low".  It has
1546 #               a 2nd, boolean, parameter which indicates if the first one
1547 #               points to a UTF-8 string or not.  It excludes any ASCII-range
1548 #               matches, but otherwise it works in all circumstances.
1549 #   cp          generate a macro whose name is 'is_BASE_cp' and defines a
1550 #               class that returns true if the UV parameter is a member of the
1551 #               class; false if not.
1552 #   cp_high     like cp, but it is assumed that it is known that the UV
1553 #               parameter is above Latin1.  The name of the generated macro is
1554 #               'is_BASE_cp_high'.  This is different from high-cp, derived
1555 #               below.
1556 # A macro of the given type is generated for each type listed in the input.
1557 # The default return value is the number of octets read to generate the match.
1558 # Append "-cp" to the type to have it instead return the matched codepoint.
1559 #               The macro name is changed to 'what_BASE...'.  See pod for
1560 #               caveats
1561 # Appending '-both" instead adds an extra parameter to the end of the argument
1562 #               list, which is a pointer as to where to store the number of
1563 #               bytes matched, while also returning the code point.  The macro
1564 #               name is changed to 'what_len_BASE...'.  See pod for caveats
1565 #
1566 # Valid modifiers:
1567 #   safe        The input string is not necessarily valid UTF-8.  In
1568 #               particular an extra parameter (always the 2nd) to the macro is
1569 #               required, which points to one beyond the end of the string.
1570 #               The macro will make sure not to read off the end of the
1571 #               string.  In the case of non-UTF8, it makes sure that the
1572 #               string has at least one byte in it.  The macro name has
1573 #               '_safe' appended to it.
1574 #   no_length_checks  The input string is not necessarily valid UTF-8, but it
1575 #               is to be assumed that the length has already been checked and
1576 #               found to be valid
1577 #   fast        The input string is valid UTF-8.  No bounds checking is done,
1578 #               and the macro can make assumptions that lead to faster
1579 #               execution.
1580 #   only_ascii_platform   Skip this definition if the character set is for
1581 #               a non-ASCII platform.
1582 #   only_ebcdic_platform  Skip this definition if the character set is for
1583 #               a non-EBCDIC platform.
1584 # No modifier need be specified; fast is assumed for this case.  If both
1585 # 'fast', and 'safe' are specified, two macros will be created for each
1586 # 'type'.
1587 #
1588 # If run on a non-ASCII platform will automatically convert the Unicode input
1589 # to native.  The documentation above is slightly wrong in this case.  'low'
1590 # actually refers to code points whose UTF-8 representation is the same as the
1591 # non-UTF-8 version (invariants); and 'latin1' refers to all the rest of the
1592 # code points less than 256.
1593
1594 1; # in the unlikely case we are being used as a module
1595
1596 __DATA__
1597 # This is no longer used, but retained in case it is needed some day.
1598 # TRICKYFOLD: Problematic fold case letters.  When adding to this list, also should add them to regcomp.c and fold_grind.t
1599 # => generic cp generic-cp generic-both :fast safe
1600 # 0x00DF        # LATIN SMALL LETTER SHARP S
1601 # 0x0390        # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
1602 # 0x03B0        # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
1603 # 0x1E9E  # LATIN CAPITAL LETTER SHARP S, because maps to same as 00DF
1604 # 0x1FD3  # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA; maps same as 0390
1605 # 0x1FE3  # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA; maps same as 03B0
1606
1607 LNBREAK: Line Break: \R
1608 => generic UTF8 LATIN1 : safe
1609 "\x0D\x0A"      # CRLF - Network (Windows) line ending
1610 \p{VertSpace}
1611
1612 HORIZWS: Horizontal Whitespace: \h \H
1613 => high cp_high : fast
1614 \p{HorizSpace}
1615
1616 VERTWS: Vertical Whitespace: \v \V
1617 => high cp_high : fast
1618 \p{VertSpace}
1619
1620 XDIGIT: Hexadecimal digits
1621 => high cp_high : fast
1622 \p{XDigit}
1623
1624 XPERLSPACE: \p{XPerlSpace}
1625 => high cp_high : fast
1626 \p{XPerlSpace}
1627
1628 REPLACEMENT: Unicode REPLACEMENT CHARACTER
1629 => UTF8 :safe
1630 0xFFFD
1631
1632 NONCHAR: Non character code points
1633 => UTF8 :safe
1634 \p{_Perl_Nchar}
1635
1636 SURROGATE: Surrogate code points
1637 => UTF8 :safe
1638 \p{_Perl_Surrogate}
1639
1640 # This program was run with this enabled, and the results copied to utf8.h and
1641 # utfebcdic.h; then this was commented out because it takes so long to figure
1642 # out these 2 million code points.  The results would not change unless utf8.h
1643 # decides it wants a different maximum, or this program creates better
1644 # optimizations.  Trying with 5 bytes used too much memory to calculate.
1645 #
1646 # We don't generate code for invariants here because the EBCDIC form is too
1647 # complicated and would slow things down; instead the user should test for
1648 # invariants first.
1649 #
1650 # 0x1FFFFF was chosen because for both UTF-8 and UTF-EBCDIC, its start byte
1651 # is the same as 0x10FFFF, and it includes all the above-Unicode code points
1652 # that have that start byte.  In other words, it is the natural stopping place
1653 # that includes all Unicode code points.
1654 #
1655 #UTF8_CHAR: Matches legal UTF-8 variant code points up through the 0x1FFFFFF
1656 #=> UTF8 :no_length_checks only_ascii_platform
1657 #0x80 - 0x1FFFFF
1658
1659 #UTF8_CHAR: Matches legal UTF-EBCDIC variant code points up through 0x1FFFFFF
1660 #=> UTF8 :no_length_checks only_ebcdic_platform
1661 #0xA0 - 0x1FFFFF
1662
1663 #STRICT_UTF8_CHAR: Matches legal Unicode UTF-8 variant code points, no surrrogates nor non-character code points
1664 #=> UTF8 :no_length_checks only_ascii_platform
1665 #0x0080 - 0xD7FF
1666 #0xE000 - 0xFDCF
1667 #0xFDF0 - 0xFFFD
1668 #0x10000 - 0x1FFFD
1669 #0x20000 - 0x2FFFD
1670 #0x30000 - 0x3FFFD
1671 #0x40000 - 0x4FFFD
1672 #0x50000 - 0x5FFFD
1673 #0x60000 - 0x6FFFD
1674 #0x70000 - 0x7FFFD
1675 #0x80000 - 0x8FFFD
1676 #0x90000 - 0x9FFFD
1677 #0xA0000 - 0xAFFFD
1678 #0xB0000 - 0xBFFFD
1679 #0xC0000 - 0xCFFFD
1680 #0xD0000 - 0xDFFFD
1681 #0xE0000 - 0xEFFFD
1682 #0xF0000 - 0xFFFFD
1683 #0x100000 - 0x10FFFD
1684 #
1685 #STRICT_UTF8_CHAR: Matches legal Unicode UTF-8 variant code points, no surrrogates nor non-character code points
1686 #=> UTF8 :no_length_checks only_ebcdic_platform
1687 #0x00A0 - 0xD7FF
1688 #0xE000 - 0xFDCF
1689 #0xFDF0 - 0xFFFD
1690 #0x10000 - 0x1FFFD
1691 #0x20000 - 0x2FFFD
1692 #0x30000 - 0x3FFFD
1693 #0x40000 - 0x4FFFD
1694 #0x50000 - 0x5FFFD
1695 #0x60000 - 0x6FFFD
1696 #0x70000 - 0x7FFFD
1697 #0x80000 - 0x8FFFD
1698 #0x90000 - 0x9FFFD
1699 #0xA0000 - 0xAFFFD
1700 #0xB0000 - 0xBFFFD
1701 #0xC0000 - 0xCFFFD
1702 #0xD0000 - 0xDFFFD
1703 #0xE0000 - 0xEFFFD
1704 #0xF0000 - 0xFFFFD
1705 #0x100000 - 0x10FFFD
1706
1707 #C9_STRICT_UTF8_CHAR: Matches legal Unicode UTF-8 variant code points, no surrogates
1708 #=> UTF8 :no_length_checks only_ascii_platform
1709 #0x0080 - 0xD7FF
1710 #0xE000 - 0x10FFFF
1711 #
1712 #C9_STRICT_UTF8_CHAR: Matches legal Unicode UTF-8 variant code points including non-character code points, no surrogates
1713 #=> UTF8 :no_length_checks only_ebcdic_platform
1714 #0x00A0 - 0xD7FF
1715 #0xE000 - 0x10FFFF
1716
1717 QUOTEMETA: Meta-characters that \Q should quote
1718 => high :fast
1719 \p{_Perl_Quotemeta}
1720
1721 MULTI_CHAR_FOLD: multi-char strings that are folded to by a single character
1722 => UTF8 :safe
1723
1724 # 1 => All folds
1725 &regcharclass_multi_char_folds::multi_char_folds(1)
1726
1727 MULTI_CHAR_FOLD: multi-char strings that are folded to by a single character
1728 => LATIN1 : safe
1729
1730 &regcharclass_multi_char_folds::multi_char_folds(0)
1731 # 0 => Latin1-only
1732
1733 FOLDS_TO_MULTI: characters that fold to multi-char strings
1734 => UTF8 :fast
1735 \p{_Perl_Folds_To_Multi_Char}
1736
1737 PROBLEMATIC_LOCALE_FOLD : characters whose fold is problematic under locale
1738 => UTF8 cp :fast
1739 \p{_Perl_Problematic_Locale_Folds}
1740
1741 PROBLEMATIC_LOCALE_FOLDEDS_START : The first folded character of folds which are problematic under locale
1742 => UTF8 cp :fast
1743 \p{_Perl_Problematic_Locale_Foldeds_Start}
1744
1745 PATWS: pattern white space
1746 => generic cp : safe
1747 \p{_Perl_PatWS}