This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/regcharclass.pl: White-space only
[perl5.git] / regen / regcharclass.pl
1 package CharClass::Matcher;
2 use strict;
3 use 5.008;
4 use warnings;
5 use warnings FATAL => 'all';
6 use Text::Wrap qw(wrap);
7 use Data::Dumper;
8 $Data::Dumper::Useqq= 1;
9 our $hex_fmt= "0x%02X";
10
11 sub ASCII_PLATFORM { (ord('A') == 65) }
12
13 require 'regen/regen_lib.pl';
14
15 =head1 NAME
16
17 CharClass::Matcher -- Generate C macros that match character classes efficiently
18
19 =head1 SYNOPSIS
20
21     perl Porting/regcharclass.pl
22
23 =head1 DESCRIPTION
24
25 Dynamically generates macros for detecting special charclasses
26 in latin-1, utf8, and codepoint forms. Macros can be set to return
27 the length (in bytes) of the matched codepoint, and/or the codepoint itself.
28
29 To regenerate F<regcharclass.h>, run this script from perl-root. No arguments
30 are necessary.
31
32 Using WHATEVER as an example the following macros can be produced, depending
33 on the input parameters (how to get each is described by internal comments at
34 the C<__DATA__> line):
35
36 =over 4
37
38 =item C<is_WHATEVER(s,is_utf8)>
39
40 =item C<is_WHATEVER_safe(s,e,is_utf8)>
41
42 Do a lookup as appropriate based on the C<is_utf8> flag. When possible
43 comparisons involving octect<128 are done before checking the C<is_utf8>
44 flag, hopefully saving time.
45
46 The version without the C<_safe> suffix should be used only when the input is
47 known to be well-formed.
48
49 =item C<is_WHATEVER_utf8(s)>
50
51 =item C<is_WHATEVER_utf8_safe(s,e)>
52
53 Do a lookup assuming the string is encoded in (normalized) UTF8.
54
55 The version without the C<_safe> suffix should be used only when the input is
56 known to be well-formed.
57
58 =item C<is_WHATEVER_latin1(s)>
59
60 =item C<is_WHATEVER_latin1_safe(s,e)>
61
62 Do a lookup assuming the string is encoded in latin-1 (aka plan octets).
63
64 The version without the C<_safe> suffix should be used only when it is known
65 that C<s> contains at least one character.
66
67 =item C<is_WHATEVER_cp(cp)>
68
69 Check to see if the string matches a given codepoint (hypothetically a
70 U32). The condition is constructed as as to "break out" as early as
71 possible if the codepoint is out of range of the condition.
72
73 IOW:
74
75   (cp==X || (cp>X && (cp==Y || (cp>Y && ...))))
76
77 Thus if the character is X+1 only two comparisons will be done. Making
78 matching lookups slower, but non-matching faster.
79
80 =item C<what_len_WHATEVER_FOO(arg1, ..., len)>
81
82 A variant form of each of the macro types described above can be generated, in
83 which the code point is returned by the macro, and an extra parameter (in the
84 final position) is added, which is a pointer for the macro to set the byte
85 length of the returned code point.
86
87 These forms all have a C<what_len> prefix instead of the C<is_>, for example
88 C<what_len_WHATEVER_safe(s,e,is_utf8,len)> and
89 C<what_len_WHATEVER_utf8(s,len)>.
90
91 These forms should not be used I<except> on small sets of mostly widely
92 separated code points; otherwise the code generated is inefficient.  For these
93 cases, it is best to use the C<is_> forms, and then find the code point with
94 C<utf8_to_uvchr_buf>().  This program can fail with a "deep recursion"
95 message on the worst of the inappropriate sets.  Examine the generated macro
96 to see if it is acceptable.
97
98 =item C<what_WHATEVER_FOO(arg1, ...)>
99
100 A variant form of each of the C<is_> macro types described above can be generated, in
101 which the code point and not the length is returned by the macro.  These have
102 the same caveat as L</what_len_WHATEVER_FOO(arg1, ..., len)>, plus they should
103 not be used where the set contains a NULL, as 0 is returned for two different
104 cases: a) the set doesn't include the input code point; b) the set does
105 include it, and it is a NULL.
106
107 =back
108
109 =head2 CODE FORMAT
110
111 perltidy  -st -bt=1 -bbt=0 -pt=0 -sbt=1 -ce -nwls== "%f"
112
113
114 =head1 AUTHOR
115
116 Author: Yves Orton (demerphq) 2007.  Maintained by Perl5 Porters.
117
118 =head1 BUGS
119
120 No tests directly here (although the regex engine will fail tests
121 if this code is broken). Insufficient documentation and no Getopts
122 handler for using the module as a script.
123
124 =head1 LICENSE
125
126 You may distribute under the terms of either the GNU General Public
127 License or the Artistic License, as specified in the README file.
128
129 =cut
130
131 # Sub naming convention:
132 # __func : private subroutine, can not be called as a method
133 # _func  : private method, not meant for external use
134 # func   : public method.
135
136 # private subs
137 #-------------------------------------------------------------------------------
138 #
139 # ($cp,$n,$l,$u)=__uni_latin($str);
140 #
141 # Return a list of arrays, each of which when interpreted correctly
142 # represent the string in some given encoding with specific conditions.
143 #
144 # $cp - list of codepoints that make up the string.
145 # $n  - list of octets that make up the string if all codepoints are invariant
146 #       regardless of if the string is in UTF-8 or not.
147 # $l  - list of octets that make up the string in latin1 encoding if all
148 #       codepoints < 256, and at least one codepoint is UTF-8 variant.
149 # $u  - list of octets that make up the string in utf8 if any codepoint is
150 #       UTF-8 variant
151 #
152 #   High CP | Defined
153 #-----------+----------
154 #   0 - 127 : $n            (127/128 are the values for ASCII platforms)
155 # 128 - 255 : $l, $u
156 # 256 - ... : $u
157 #
158
159 sub __uni_latin1 {
160     my $str= shift;
161     my $max= 0;
162     my @cp;
163     my $only_has_invariants = 1;
164     for my $ch ( split //, $str ) {
165         my $cp= ord $ch;
166         push @cp, $cp;
167         $max= $cp if $max < $cp;
168         if (! ASCII_PLATFORM && $only_has_invariants) {
169             if ($cp > 255) {
170                 $only_has_invariants = 0;
171             }
172             else {
173                 my $temp = chr($cp);
174                 utf8::upgrade($temp);
175                 my @utf8 = unpack "U0C*", $temp;
176                 $only_has_invariants = (@utf8 == 1 && $utf8[0] == $cp);
177             }
178         }
179     }
180     my ( $n, $l, $u );
181     $only_has_invariants = $max < 128 if ASCII_PLATFORM;
182     if ($only_has_invariants) {
183         $n= [@cp];
184     } else {
185         $l= [@cp] if $max && $max < 256;
186
187         $u= $str;
188         utf8::upgrade($u);
189         $u= [ unpack "U0C*", $u ] if defined $u;
190     }
191     return ( \@cp, $n, $l, $u );
192 }
193
194 #
195 # $clean= __clean($expr);
196 #
197 # Cleanup a ternary expression, removing unnecessary parens and apply some
198 # simplifications using regexes.
199 #
200
201 sub __clean {
202     my ( $expr )= @_;
203     our $parens;
204     $parens= qr/ (?> \( (?> (?: (?> [^()]+ ) | (??{ $parens }) )* ) \) ) /x;
205
206     #print "$parens\n$expr\n";
207     1 while $expr =~ s/ \( \s* ( $parens ) \s* \) /$1/gx;
208     1 while $expr =~ s/ \( \s* ($parens) \s* \? \s*
209         \( \s* ($parens) \s* \? \s* ($parens|[^:]+?) \s* : \s* ($parens|[^)]+?) \s* \)
210         \s* : \s* \4 \s* \)/( ( $1 && $2 ) ? $3 : 0 )/gx;
211     return $expr;
212 }
213
214 #
215 # $text= __macro(@args);
216 # Join args together by newlines, and then neatly add backslashes to the end
217 # of every  line as expected by the C pre-processor for #define's.
218 #
219
220 sub __macro {
221     my $str= join "\n", @_;
222     $str =~ s/\s*$//;
223     my @lines= map { s/\s+$//; s/\t/        /g; $_ } split /\n/, $str;
224     my $last= pop @lines;
225     $str= join "\n", ( map { sprintf "%-76s\\", $_ } @lines ), $last;
226     1 while $str =~ s/^(\t*) {8}/$1\t/gm;
227     return $str . "\n";
228 }
229
230 #
231 # my $op=__incrdepth($op);
232 #
233 # take an 'op' hashref and add one to it and all its childrens depths.
234 #
235
236 sub __incrdepth {
237     my $op= shift;
238     return unless ref $op;
239     $op->{depth} += 1;
240     __incrdepth( $op->{yes} );
241     __incrdepth( $op->{no} );
242     return $op;
243 }
244
245 # join two branches of an opcode together with a condition, incrementing
246 # the depth on the yes branch when we do so.
247 # returns the new root opcode of the tree.
248 sub __cond_join {
249     my ( $cond, $yes, $no )= @_;
250     return {
251         test  => $cond,
252         yes   => __incrdepth( $yes ),
253         no    => $no,
254         depth => 0,
255     };
256 }
257
258 # Methods
259
260 # constructor
261 #
262 # my $obj=CLASS->new(op=>'SOMENAME',title=>'blah',txt=>[..]);
263 #
264 # Create a new CharClass::Matcher object by parsing the text in
265 # the txt array. Currently applies the following rules:
266 #
267 # Element starts with C<0x>, line is evaled the result treated as
268 # a number which is passed to chr().
269 #
270 # Element starts with C<">, line is evaled and the result treated
271 # as a string.
272 #
273 # Each string is then stored in the 'strs' subhash as a hash record
274 # made up of the results of __uni_latin1, using the keynames
275 # 'low','latin1','utf8', as well as the synthesized 'LATIN1', 'high', and
276 # 'UTF8' which hold a merge of 'low' and their lowercase equivelents.
277 #
278 # Size data is tracked per type in the 'size' subhash.
279 #
280 # Return an object
281 #
282 sub new {
283     my $class= shift;
284     my %opt= @_;
285     for ( qw(op txt) ) {
286         die "in " . __PACKAGE__ . " constructor '$_;' is a mandatory field"
287           if !exists $opt{$_};
288     }
289
290     my $self= bless {
291         op    => $opt{op},
292         title => $opt{title} || '',
293     }, $class;
294     foreach my $txt ( @{ $opt{txt} } ) {
295         my $str= $txt;
296         if ( $str =~ /^[""]/ ) {
297             $str= eval $str;
298         } elsif ($str =~ / - /x ) { # A range:  Replace this element on the
299                                     # list with its expansion
300             my ($lower, $upper) = $str =~ / 0x (.+?) \s* - \s* 0x (.+) /x;
301             die "Format must be like '0xDEAD - 0xBEAF'; instead was '$str'" if ! defined $lower || ! defined $upper;
302             foreach my $cp (hex $lower .. hex $upper) {
303                 push @{$opt{txt}}, sprintf "0x%X", $cp;
304             }
305             next;
306         } elsif ($str =~ s/ ^ N (?= 0x ) //x ) {
307             # Otherwise undocumented, a leading N means is already in the
308             # native character set; don't convert.
309             $str= chr eval $str;
310         } elsif ( $str =~ /^0x/ ) {
311             $str= eval $str;
312
313             # Convert from Unicode/ASCII to native, if necessary
314             $str = utf8::unicode_to_native($str) if ! ASCII_PLATFORM
315                                                     && $str <= 0xFF;
316             $str = chr $str;
317         } elsif ( $str =~ / \s* \\p \{ ( .*? ) \} /x) {
318             my $property = $1;
319             use Unicode::UCD qw(prop_invlist);
320
321             my @invlist = prop_invlist($property, '_perl_core_internal_ok');
322             if (! @invlist) {
323
324                 # An empty return could mean an unknown property, or merely
325                 # that it is empty.  Call in scalar context to differentiate
326                 my $count = prop_invlist($property, '_perl_core_internal_ok');
327                 die "$property not found" unless defined $count;
328             }
329
330             # Replace this element on the list with the property's expansion
331             for (my $i = 0; $i < @invlist; $i += 2) {
332                 foreach my $cp ($invlist[$i] .. $invlist[$i+1] - 1) {
333
334                     # prop_invlist() returns native values; add leading 'N'
335                     # to indicate that.
336                     push @{$opt{txt}}, sprintf "N0x%X", $cp;
337                 }
338             }
339             next;
340         } else {
341             die "Unparsable line: $txt\n";
342         }
343         my ( $cp, $low, $latin1, $utf8 )= __uni_latin1( $str );
344         my $UTF8= $low   || $utf8;
345         my $LATIN1= $low || $latin1;
346         my $high = (scalar grep { $_ < 256 } @$cp) ? 0 : $utf8;
347         #die Dumper($txt,$cp,$low,$latin1,$utf8)
348         #    if $txt=~/NEL/ or $utf8 and @$utf8>3;
349
350         @{ $self->{strs}{$str} }{qw( str txt low utf8 latin1 high cp UTF8 LATIN1 )}=
351           ( $str, $txt, $low, $utf8, $latin1, $high, $cp, $UTF8, $LATIN1 );
352         my $rec= $self->{strs}{$str};
353         foreach my $key ( qw(low utf8 latin1 high cp UTF8 LATIN1) ) {
354             $self->{size}{$key}{ 0 + @{ $self->{strs}{$str}{$key} } }++
355               if $self->{strs}{$str}{$key};
356         }
357         $self->{has_multi} ||= @$cp > 1;
358         $self->{has_ascii} ||= $latin1 && @$latin1;
359         $self->{has_low}   ||= $low && @$low;
360         $self->{has_high}  ||= !$low && !$latin1;
361     }
362     $self->{val_fmt}= $hex_fmt;
363     $self->{count}= 0 + keys %{ $self->{strs} };
364     return $self;
365 }
366
367 # my $trie = make_trie($type,$maxlen);
368 #
369 # using the data stored in the object build a trie of a specific type,
370 # and with specific maximum depth. The trie is made up the elements of
371 # the given types array for each string in the object (assuming it is
372 # not too long.)
373 #
374 # returns the trie, or undef if there was no relevant data in the object.
375 #
376
377 sub make_trie {
378     my ( $self, $type, $maxlen )= @_;
379
380     my $strs= $self->{strs};
381     my %trie;
382     foreach my $rec ( values %$strs ) {
383         die "panic: unknown type '$type'"
384           if !exists $rec->{$type};
385         my $dat= $rec->{$type};
386         next unless $dat;
387         next if $maxlen && @$dat > $maxlen;
388         my $node= \%trie;
389         foreach my $elem ( @$dat ) {
390             $node->{$elem} ||= {};
391             $node= $node->{$elem};
392         }
393         $node->{''}= $rec->{str};
394     }
395     return 0 + keys( %trie ) ? \%trie : undef;
396 }
397
398 sub pop_count ($) {
399     my $word = shift;
400
401     # This returns a list of the positions of the bits in the input word that
402     # are 1.
403
404     my @positions;
405     my $position = 0;
406     while ($word) {
407         push @positions, $position if $word & 1;
408         $position++;
409         $word >>= 1;
410     }
411     return @positions;
412 }
413
414 # my $optree= _optree()
415 #
416 # recursively convert a trie to an optree where every node represents
417 # an if else branch.
418 #
419 #
420
421 sub _optree {
422     my ( $self, $trie, $test_type, $ret_type, $else, $depth )= @_;
423     return unless defined $trie;
424     if ( $self->{has_multi} and $ret_type =~ /cp|both/ ) {
425         die "Can't do 'cp' optree from multi-codepoint strings";
426     }
427     $ret_type ||= 'len';
428     $else= 0  unless defined $else;
429     $depth= 0 unless defined $depth;
430
431     my @conds= sort { $a <=> $b } grep { length $_ } keys %$trie;
432     if (exists $trie->{''} ) {
433         if ( $ret_type eq 'cp' ) {
434             $else= $self->{strs}{ $trie->{''} }{cp}[0];
435             $else= sprintf "$self->{val_fmt}", $else if $else > 9;
436         } elsif ( $ret_type eq 'len' ) {
437             $else= $depth;
438         } elsif ( $ret_type eq 'both') {
439             $else= $self->{strs}{ $trie->{''} }{cp}[0];
440             $else= sprintf "$self->{val_fmt}", $else if $else > 9;
441             $else= "len=$depth, $else";
442         }
443     }
444     return $else if !@conds;
445     my $node= {};
446     my $root= $node;
447     my ( $yes_res, $as_code, @cond );
448     my $test= $test_type eq 'cp' ? "cp" : "((U8*)s)[$depth]";
449     my $Update= sub {
450         $node->{vals}= [@cond];
451         $node->{test}= $test;
452         $node->{yes}= $yes_res;
453         $node->{depth}= $depth;
454         $node->{no}= shift;
455     };
456     while ( @conds ) {
457         my $cond= shift @conds;
458         my $res=
459           $self->_optree( $trie->{$cond}, $test_type, $ret_type, $else,
460             $depth + 1 );
461         my $res_code= Dumper( $res );
462         if ( !$yes_res || $res_code ne $as_code ) {
463             if ( $yes_res ) {
464                 $Update->( {} );
465                 $node= $node->{no};
466             }
467             ( $yes_res, $as_code )= ( $res, $res_code );
468             @cond= ( $cond );
469         } else {
470             push @cond, $cond;
471         }
472     }
473     $Update->( $else );
474     return $root;
475 }
476
477 # my $optree= optree(%opts);
478 #
479 # Convert a trie to an optree, wrapper for _optree
480
481 sub optree {
482     my $self= shift;
483     my %opt= @_;
484     my $trie= $self->make_trie( $opt{type}, $opt{max_depth} );
485     $opt{ret_type} ||= 'len';
486     my $test_type= $opt{type} eq 'cp' ? 'cp' : 'depth';
487     return $self->_optree( $trie, $test_type, $opt{ret_type}, $opt{else}, 0 );
488 }
489
490 # my $optree= generic_optree(%opts);
491 #
492 # build a "generic" optree out of the three 'low', 'latin1', 'utf8'
493 # sets of strings, including a branch for handling the string type check.
494 #
495
496 sub generic_optree {
497     my $self= shift;
498     my %opt= @_;
499
500     $opt{ret_type} ||= 'len';
501     my $test_type= 'depth';
502     my $else= $opt{else} || 0;
503
504     my $latin1= $self->make_trie( 'latin1', $opt{max_depth} );
505     my $utf8= $self->make_trie( 'utf8',     $opt{max_depth} );
506
507     $_= $self->_optree( $_, $test_type, $opt{ret_type}, $else, 0 )
508       for $latin1, $utf8;
509
510     if ( $utf8 ) {
511         $else= __cond_join( "( is_utf8 )", $utf8, $latin1 || $else );
512     } elsif ( $latin1 ) {
513         $else= __cond_join( "!( is_utf8 )", $latin1, $else );
514     }
515     my $low= $self->make_trie( 'low', $opt{max_depth} );
516     if ( $low ) {
517         $else= $self->_optree( $low, $test_type, $opt{ret_type}, $else, 0 );
518     }
519
520     return $else;
521 }
522
523 # length_optree()
524 #
525 # create a string length guarded optree.
526 #
527
528 sub length_optree {
529     my $self= shift;
530     my %opt= @_;
531     my $type= $opt{type};
532
533     die "Can't do a length_optree on type 'cp', makes no sense."
534       if $type eq 'cp';
535
536     my ( @size, $method );
537
538     if ( $type eq 'generic' ) {
539         $method= 'generic_optree';
540         my %sizes= (
541             %{ $self->{size}{low}    || {} },
542             %{ $self->{size}{latin1} || {} },
543             %{ $self->{size}{utf8}   || {} }
544         );
545         @size= sort { $a <=> $b } keys %sizes;
546     } else {
547         $method= 'optree';
548         @size= sort { $a <=> $b } keys %{ $self->{size}{$type} };
549     }
550
551     my $else= ( $opt{else} ||= 0 );
552     for my $size ( @size ) {
553         my $optree= $self->$method( %opt, type => $type, max_depth => $size );
554         my $cond= "((e)-(s) > " . ( $size - 1 ).")";
555         $else= __cond_join( $cond, $optree, $else );
556     }
557     return $else;
558 }
559
560 sub calculate_mask(@) {
561     my @list = @_;
562     my $list_count = @list;
563
564     # Look at the input list of byte values.  This routine sees if the set
565     # consisting of those bytes is exactly determinable by using a
566     # mask/compare operation.  If not, it returns an empty list; if so, it
567     # returns a list consisting of (mask, compare).  For example, consider a
568     # set consisting of the numbers 0xF0, 0xF1, 0xF2, and 0xF3.  If we want to
569     # know if a number 'c' is in the set, we could write:
570     #   0xF0 <= c && c <= 0xF4
571     # But the following mask/compare also works, and has just one test:
572     #   c & 0xFC == 0xF0
573     # The reason it works is that the set consists of exactly those numbers
574     # whose first 4 bits are 1, and the next two are 0.  (The value of the
575     # other 2 bits is immaterial in determining if a number is in the set or
576     # not.)  The mask masks out those 2 irrelevant bits, and the comparison
577     # makes sure that the result matches all bytes that which match those 6
578     # material bits exactly.  In other words, the set of numbers contains
579     # exactly those whose bottom two bit positions are either 0 or 1.  The
580     # same principle applies to bit positions that are not necessarily
581     # adjacent.  And it can be applied to bytes that differ in 1 through all 8
582     # bit positions.  In order to be a candidate for this optimization, the
583     # number of numbers in the test must be a power of 2.  Based on this
584     # count, we know the number of bit positions that must differ.
585     my $bit_diff_count = 0;
586     my $compare = $list[0];
587     if ($list_count == 2) {
588         $bit_diff_count = 1;
589     }
590     elsif ($list_count == 4) {
591         $bit_diff_count = 2;
592     }
593     elsif ($list_count == 8) {
594         $bit_diff_count = 3;
595     }
596     elsif ($list_count == 16) {
597         $bit_diff_count = 4;
598     }
599     elsif ($list_count == 32) {
600         $bit_diff_count = 5;
601     }
602     elsif ($list_count == 64) {
603         $bit_diff_count = 6;
604     }
605     elsif ($list_count == 128) {
606         $bit_diff_count = 7;
607     }
608     elsif ($list_count == 256) {
609         return (0, 0);
610     }
611
612     # If the count wasn't a power of 2, we can't apply this optimization
613     return if ! $bit_diff_count;
614
615     my %bit_map;
616
617     # For each byte in the list, find the bit positions in it whose value
618     # differs from the first byte in the set.
619     for (my $i = 1; $i < @list; $i++) {
620         my @positions = pop_count($list[0] ^ $list[$i]);
621
622         # If the number of differing bits is greater than those permitted by
623         # the set size, this optimization doesn't apply.
624         return if @positions > $bit_diff_count;
625
626         # Save the bit positions that differ.
627         foreach my $bit (@positions) {
628             $bit_map{$bit} = 1;
629         }
630
631         # If the total so far is greater than those permitted by the set size,
632         # this optimization doesn't apply.
633         return if keys %bit_map > $bit_diff_count;
634
635
636         # The value to compare against is the AND of all the members of the
637         # set.  The bit positions that are the same in all will be correct in
638         # the AND, and the bit positions that differ will be 0.
639         $compare &= $list[$i];
640     }
641
642     # To get to here, we have gone through all bytes in the set,
643     # and determined that they all differ from each other in at most
644     # the number of bits allowed for the set's quantity.  And since we have
645     # tested all 2**N possibilities, we know that the set includes no fewer
646     # elements than we need,, so the optimization applies.
647     die "panic: internal logic error" if keys %bit_map != $bit_diff_count;
648
649     # The mask is the bit positions where things differ, complemented.
650     my $mask = 0;
651     foreach my $position (keys %bit_map) {
652         $mask |= 1 << $position;
653     }
654     $mask = ~$mask & 0xFF;
655
656     return ($mask, $compare);
657 }
658
659 # _cond_as_str
660 # turn a list of conditions into a text expression
661 # - merges ranges of conditions, and joins the result with ||
662 sub _cond_as_str {
663     my ( $self, $op, $combine, $opts_ref )= @_;
664     my $cond= $op->{vals};
665     my $test= $op->{test};
666     my $is_cp_ret = $opts_ref->{ret_type} eq "cp";
667     return "( $test )" if !defined $cond;
668
669     # rangify the list.
670     my @ranges;
671     my $Update= sub {
672         # We skip this if there are optimizations that
673         # we can apply (below) to the individual ranges
674         if ( ($is_cp_ret || $combine) && @ranges && ref $ranges[-1]) {
675             if ( $ranges[-1][0] == $ranges[-1][1] ) {
676                 $ranges[-1]= $ranges[-1][0];
677             } elsif ( $ranges[-1][0] + 1 == $ranges[-1][1] ) {
678                 $ranges[-1]= $ranges[-1][0];
679                 push @ranges, $ranges[-1] + 1;
680             }
681         }
682     };
683     for my $condition ( @$cond ) {
684         if ( !@ranges || $condition != $ranges[-1][1] + 1 ) {
685             $Update->();
686             push @ranges, [ $condition, $condition ];
687         } else {
688             $ranges[-1][1]++;
689         }
690     }
691     $Update->();
692
693     return $self->_combine( $test, @ranges )
694       if $combine;
695
696     if ($is_cp_ret) {
697         @ranges= map {
698             ref $_
699             ? sprintf(
700                 "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
701                 @$_ )
702             : sprintf( "$self->{val_fmt} == $test", $_ );
703         } @ranges;
704     }
705     else {
706         # If the input set has certain characteristics, we can optimize tests
707         # for it.  This doesn't apply if returning the code point, as we want
708         # each element of the set individually.  The code above is for this
709         # simpler case.
710
711         return 1 if @$cond == 256;  # If all bytes match, is trivially true
712
713             # See if the entire set shares optimizable characterstics, and if
714             # so, return the optimization.
715             my ($mask, $base) = calculate_mask(@$cond);
716             if (defined $mask && defined $base) {
717                 return sprintf "( ( $test & $self->{val_fmt} ) == $self->{val_fmt} )", $mask, $base;
718             }
719
720         # Here, there was no entire-class optimization.  Look at each range.
721         for (my $i = 0; $i < @ranges; $i++) {
722             if (! ref $ranges[$i]) {    # Trivial case: no range
723                 $ranges[$i] = sprintf "$self->{val_fmt} == $test", $ranges[$i];
724             }
725             elsif ($ranges[$i]->[0] == $ranges[$i]->[1]) {
726                 $ranges[$i] =           # Trivial case: single element range
727                         sprintf "$self->{val_fmt} == $test", $ranges[$i]->[0];
728             }
729             else {
730                 my $output = "";
731
732                 # See if the number of elements is a power of 2 (only a single
733                 # bit in the representation of its count will be set) and if
734                 # so, it may be that a mask/compare optimization is possible.
735                 if (pop_count($ranges[$i]->[1] - $ranges[$i]->[0] + 1) == 1) {
736                     my @list;
737                     push @list, $_  for ($ranges[$i]->[0] .. $ranges[$i]->[1]);
738                     my ($mask, $base) = calculate_mask(@list);
739                     if (defined $mask && defined $base) {
740                         $output = sprintf "( $test & $self->{val_fmt} ) == $self->{val_fmt}", $mask, $base;
741                     }
742                 }
743
744                 if ($output ne "") {  # Prefer any optimization
745                     $ranges[$i] = $output;
746                 }
747                 elsif ($ranges[$i]->[0] + 1 == $ranges[$i]->[1]) {
748                     # No optimization happened.  We need a test that the code
749                     # point is within both bounds.  But, if the bounds are
750                     # adjacent code points, it is cleaner to say
751                     # 'first == test || second == test'
752                     # than it is to say
753                     # 'first <= test && test <= second'
754                     $ranges[$i] = "( "
755                                 .  join( " || ", ( map
756                                     { sprintf "$self->{val_fmt} == $test", $_ }
757                                     @{$ranges[$i]} ) )
758                                 . " )";
759                 }
760                 else {  # Full bounds checking
761                     $ranges[$i] = sprintf("( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )", $ranges[$i]->[0], $ranges[$i]->[1]);
762                 }
763             }
764         }
765     }
766
767     return "( " . join( " || ", @ranges ) . " )";
768
769 }
770
771 # _combine
772 # recursively turn a list of conditions into a fast break-out condition
773 # used by _cond_as_str() for 'cp' type macros.
774 sub _combine {
775     my ( $self, $test, @cond )= @_;
776     return if !@cond;
777     my $item= shift @cond;
778     my ( $cstr, $gtv );
779     if ( ref $item ) {
780         $cstr=
781           sprintf( "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
782             @$item );
783         $gtv= sprintf "$self->{val_fmt}", $item->[1];
784     } else {
785         $cstr= sprintf( "$self->{val_fmt} == $test", $item );
786         $gtv= sprintf "$self->{val_fmt}", $item;
787     }
788     if ( @cond ) {
789         return "( $cstr || ( $gtv < $test &&\n"
790           . $self->_combine( $test, @cond ) . " ) )";
791     } else {
792         return $cstr;
793     }
794 }
795
796 # _render()
797 # recursively convert an optree to text with reasonably neat formatting
798 sub _render {
799     my ( $self, $op, $combine, $brace, $opts_ref )= @_;
800     return 0 if ! defined $op;  # The set is empty
801     if ( !ref $op ) {
802         return $op;
803     }
804     my $cond= $self->_cond_as_str( $op, $combine, $opts_ref );
805     #no warnings 'recursion';   # This would allow really really inefficient
806                                 # code to be generated.  See pod
807     my $yes= $self->_render( $op->{yes}, $combine, 1, $opts_ref );
808     return $yes if $cond eq '1';
809
810     my $no= $self->_render( $op->{no},   $combine, 0, $opts_ref );
811     return "( $cond )" if $yes eq '1' and $no eq '0';
812     my ( $lb, $rb )= $brace ? ( "( ", " )" ) : ( "", "" );
813     return "$lb$cond ? $yes : $no$rb"
814       if !ref( $op->{yes} ) && !ref( $op->{no} );
815     my $ind1= " " x 4;
816     my $ind= "\n" . ( $ind1 x $op->{depth} );
817
818     if ( ref $op->{yes} ) {
819         $yes= $ind . $ind1 . $yes;
820     } else {
821         $yes= " " . $yes;
822     }
823
824     return "$lb$cond ?$yes$ind: $no$rb";
825 }
826
827 # $expr=render($op,$combine)
828 #
829 # convert an optree to text with reasonably neat formatting. If $combine
830 # is true then the condition is created using "fast breakouts" which
831 # produce uglier expressions that are more efficient for common case,
832 # longer lists such as that resulting from type 'cp' output.
833 # Currently only used for type 'cp' macros.
834 sub render {
835     my ( $self, $op, $combine, $opts_ref )= @_;
836     my $str= "( " . $self->_render( $op, $combine, 0, $opts_ref ) . " )";
837     return __clean( $str );
838 }
839
840 # make_macro
841 # make a macro of a given type.
842 # calls into make_trie and (generic_|length_)optree as needed
843 # Opts are:
844 # type     : 'cp','generic','high','low','latin1','utf8','LATIN1','UTF8'
845 # ret_type : 'cp' or 'len'
846 # safe     : add length guards to macro
847 #
848 # type defaults to 'generic', and ret_type to 'len' unless type is 'cp'
849 # in which case it defaults to 'cp' as well.
850 #
851 # it is illegal to do a type 'cp' macro on a pattern with multi-codepoint
852 # sequences in it, as the generated macro will accept only a single codepoint
853 # as an argument.
854 #
855 # returns the macro.
856
857
858 sub make_macro {
859     my $self= shift;
860     my %opts= @_;
861     my $type= $opts{type} || 'generic';
862     die "Can't do a 'cp' on multi-codepoint character class '$self->{op}'"
863       if $type eq 'cp'
864       and $self->{has_multi};
865     my $ret_type= $opts{ret_type} || ( $opts{type} eq 'cp' ? 'cp' : 'len' );
866     my $method;
867     if ( $opts{safe} ) {
868         $method= 'length_optree';
869     } elsif ( $type eq 'generic' ) {
870         $method= 'generic_optree';
871     } else {
872         $method= 'optree';
873     }
874     my $optree= $self->$method( %opts, type => $type, ret_type => $ret_type );
875     my $text= $self->render( $optree, $type eq 'cp', \%opts );
876     my @args= $type eq 'cp' ? 'cp' : 's';
877     push @args, "e" if $opts{safe};
878     push @args, "is_utf8" if $type eq 'generic';
879     push @args, "len" if $ret_type eq 'both';
880     my $pfx= $ret_type eq 'both'    ? 'what_len_' : 
881              $ret_type eq 'cp'      ? 'what_'     : 'is_';
882     my $ext= $type     eq 'generic' ? ''          : '_' . lc( $type );
883     $ext .= "_safe" if $opts{safe};
884     my $argstr= join ",", @args;
885     return "/*** GENERATED CODE ***/\n"
886       . __macro( "#define $pfx$self->{op}$ext($argstr)\n$text" );
887 }
888
889 # if we arent being used as a module (highly likely) then process
890 # the __DATA__ below and produce macros in regcharclass.h
891 # if an argument is provided to the script then it is assumed to
892 # be the path of the file to output to, if the arg is '-' outputs
893 # to STDOUT.
894 if ( !caller ) {
895     $|++;
896     my $path= shift @ARGV || "regcharclass.h";
897     my $out_fh;
898     if ( $path eq '-' ) {
899         $out_fh= \*STDOUT;
900     } else {
901         $out_fh = open_new( $path );
902     }
903     print $out_fh read_only_top( lang => 'C', by => $0,
904                                  file => 'regcharclass.h', style => '*',
905                                  copyright => [2007, 2011] );
906     print $out_fh "\n#ifndef H_REGCHARCLASS   /* Guard against nested #includes */\n#define H_REGCHARCLASS 1\n\n";
907
908     my ( $op, $title, @txt, @types, %mods );
909     my $doit= sub {
910         return unless $op;
911         print $out_fh "/*\n\t$op: $title\n\n";
912         print $out_fh join "\n", ( map { "\t$_" } @txt ), "*/", "";
913         my $obj= __PACKAGE__->new( op => $op, title => $title, txt => \@txt );
914
915         #die Dumper(\@types,\%mods);
916
917         my @mods;
918         push @mods, 'safe' if delete $mods{safe};
919         unshift @mods, 'fast' if delete $mods{fast} || ! @mods; # Default to 'fast'
920                                                                 # do this one
921                                                                 # first, as
922                                                                 # traditional
923         if (%mods) {
924             die "Unknown modifiers: ", join ", ", map { "'$_'" } keys %mods;
925         }
926
927         foreach my $type_spec ( @types ) {
928             my ( $type, $ret )= split /-/, $type_spec;
929             $ret ||= 'len';
930             foreach my $mod ( @mods ) {
931                 next if $mod eq 'safe' and $type eq 'cp';
932                 delete $mods{$mod};
933                 my $macro= $obj->make_macro(
934                     type     => $type,
935                     ret_type => $ret,
936                     safe     => $mod eq 'safe'
937                 );
938                 print $out_fh $macro, "\n";
939             }
940         }
941     };
942
943     while ( <DATA> ) {
944         s/^ \s* (?: \# .* ) ? $ //x;    # squeeze out comment and blanks
945         next unless /\S/;
946         chomp;
947         if ( /^([A-Z]+)/ ) {
948             $doit->();  # This starts a new definition; do the previous one
949             ( $op, $title )= split /\s*:\s*/, $_, 2;
950             @txt= ();
951         } elsif ( s/^=>// ) {
952             my ( $type, $modifier )= split /:/, $_;
953             @types= split ' ', $type;
954             undef %mods;
955             map { $mods{$_} = 1 } split ' ',  $modifier;
956         } else {
957             push @txt, "$_";
958         }
959     }
960     $doit->();
961
962     print $out_fh "\n#endif /* H_REGCHARCLASS */\n";
963
964     if($path eq '-') {
965         print $out_fh "/* ex: set ro: */\n";
966     } else {
967         read_only_bottom_close_and_rename($out_fh)
968     }
969 }
970
971 # The form of the input is a series of definitions to make macros for.
972 # The first line gives the base name of the macro, followed by a colon, and
973 # then text to be used in comments associated with the macro that are its
974 # title or description.  In all cases the first (perhaps only) parameter to
975 # the macro is a pointer to the first byte of the code point it is to test to
976 # see if it is in the class determined by the macro.  In the case of non-UTF8,
977 # the code point consists only of a single byte.
978 #
979 # The second line must begin with a '=>' and be followed by the types of
980 # macro(s) to be generated; these are specified below.  A colon follows the
981 # types, followed by the modifiers, also specified below.  At least one
982 # modifier is required.
983 #
984 # The subsequent lines give what code points go into the class defined by the
985 # macro.  Multiple characters may be specified via a string like "\x0D\x0A",
986 # enclosed in quotes.  Otherwise the lines consist of single Unicode code
987 # point, prefaced by 0x; or a single range of Unicode code points separated by
988 # a minus (and optional space); or a single Unicode property specified in the
989 # standard Perl form "\p{...}".
990 #
991 # A blank line or one whose first non-blank character is '#' is a comment.
992 # The definition of the macro is terminated by a line unlike those described.
993 #
994 # Valid types:
995 #   low         generate a macro whose name is 'is_BASE_low' and defines a
996 #               class that includes only ASCII-range chars.  (BASE is the
997 #               input macro base name.)
998 #   latin1      generate a macro whose name is 'is_BASE_latin1' and defines a
999 #               class that includes only upper-Latin1-range chars.  It is not
1000 #               designed to take a UTF-8 input parameter.
1001 #   high        generate a macro whose name is 'is_BASE_high' and defines a
1002 #               class that includes all relevant code points that are above
1003 #               the Latin1 range.  This is for very specialized uses only.
1004 #               It is designed to take only an input UTF-8 parameter.
1005 #   utf8        generate a macro whose name is 'is_BASE_utf8' and defines a
1006 #               class that includes all relevant characters that aren't ASCII.
1007 #               It is designed to take only an input UTF-8 parameter.
1008 #   LATIN1      generate a macro whose name is 'is_BASE_latin1' and defines a
1009 #               class that includes both ASCII and upper-Latin1-range chars.
1010 #               It is not designed to take a UTF-8 input parameter.
1011 #   UTF8        generate a macro whose name is 'is_BASE_utf8' and defines a
1012 #               class that can include any code point, adding the 'low' ones
1013 #               to what 'utf8' works on.  It is designed to take only an input
1014 #               UTF-8 parameter.
1015 #   generic     generate a macro whose name is 'is_BASE".  It has a 2nd,
1016 #               boolean, parameter which indicates if the first one points to
1017 #               a UTF-8 string or not.  Thus it works in all circumstances.
1018 #   cp          generate a macro whose name is 'is_BASE_cp' and defines a
1019 #               class that returns true if the UV parameter is a member of the
1020 #               class; false if not.
1021 # A macro of the given type is generated for each type listed in the input.
1022 # The default return value is the number of octets read to generate the match.
1023 # Append "-cp" to the type to have it instead return the matched codepoint.
1024 #               The macro name is changed to 'what_BASE...'.  See pod for
1025 #               caveats
1026 # Appending '-both" instead adds an extra parameter to the end of the argument
1027 #               list, which is a pointer as to where to store the number of
1028 #               bytes matched, while also returning the code point.  The macro
1029 #               name is changed to 'what_len_BASE...'.  See pod for caveats
1030 #
1031 # Valid modifiers:
1032 #   safe        The input string is not necessarily valid UTF-8.  In
1033 #               particular an extra parameter (always the 2nd) to the macro is
1034 #               required, which points to one beyond the end of the string.
1035 #               The macro will make sure not to read off the end of the
1036 #               string.  In the case of non-UTF8, it makes sure that the
1037 #               string has at least one byte in it.  The macro name has
1038 #               '_safe' appended to it.
1039 #   fast        The input string is valid UTF-8.  No bounds checking is done,
1040 #               and the macro can make assumptions that lead to faster
1041 #               execution.
1042 # No modifier need be specified; fast is assumed for this case.  If both
1043 # 'fast', and 'safe' are specified, two macros will be created for each
1044 # 'type'.
1045 #
1046 # If run on a non-ASCII platform will automatically convert the Unicode input
1047 # to native.  The documentation above is slightly wrong in this case.  'low'
1048 # actually refers to code points whose UTF-8 representation is the same as the
1049 # non-UTF-8 version (invariants); and 'latin1' refers to all the rest of the
1050 # code points less than 256.
1051
1052 1; # in the unlikely case we are being used as a module
1053
1054 __DATA__
1055 # This is no longer used, but retained in case it is needed some day.
1056 # TRICKYFOLD: Problematic fold case letters.  When adding to this list, also should add them to regcomp.c and fold_grind.t
1057 # => generic cp generic-cp generic-both :fast safe
1058 # 0x00DF        # LATIN SMALL LETTER SHARP S
1059 # 0x0390        # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
1060 # 0x03B0        # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
1061 # 0x1E9E  # LATIN CAPITAL LETTER SHARP S, because maps to same as 00DF
1062 # 0x1FD3  # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA; maps same as 0390
1063 # 0x1FE3  # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA; maps same as 03B0
1064
1065 LNBREAK: Line Break: \R
1066 => generic UTF8 LATIN1 :fast safe
1067 "\x0D\x0A"      # CRLF - Network (Windows) line ending
1068 \p{VertSpace}
1069
1070 HORIZWS: Horizontal Whitespace: \h \H
1071 => generic UTF8 LATIN1 cp :fast safe
1072 \p{HorizSpace}
1073
1074 VERTWS: Vertical Whitespace: \v \V
1075 => generic UTF8 LATIN1 cp :fast safe
1076 \p{VertSpace}
1077
1078 GCB_L: Grapheme_Cluster_Break=L
1079 => UTF8 :fast
1080 \p{_X_GCB_L}
1081
1082 GCB_LV_LVT_V: Grapheme_Cluster_Break=(LV or LVT or V)
1083 => UTF8 :fast
1084 \p{_X_LV_LVT_V}
1085
1086 GCB_Prepend: Grapheme_Cluster_Break=Prepend
1087 => UTF8 :fast
1088 \p{_X_GCB_Prepend}
1089
1090 GCB_RI: Grapheme_Cluster_Break=RI
1091 => UTF8 :fast
1092 \p{_X_RI}
1093
1094 GCB_SPECIAL_BEGIN: Grapheme_Cluster_Break=special_begins
1095 => UTF8 :fast
1096 \p{_X_Special_Begin}
1097
1098 GCB_T: Grapheme_Cluster_Break=T
1099 => UTF8 :fast
1100 \p{_X_GCB_T}
1101
1102 GCB_V: Grapheme_Cluster_Break=V
1103 => UTF8 :fast
1104 \p{_X_GCB_V}
1105
1106 QUOTEMETA: Meta-characters that \Q should quote
1107 => high :fast
1108 \p{_Perl_Quotemeta}