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