1 package CharClass::Matcher;
5 use warnings FATAL => 'all';
6 use Text::Wrap qw(wrap);
9 $Data::Dumper::Useqq= 1;
10 our $hex_fmt= "0x%02X";
12 require 'regen/regen_lib.pl';
16 CharClass::Matcher -- Generate C macros that match character classes efficiently
20 perl Porting/regcharclass.pl
24 Dynamically generates macros for detecting special charclasses
25 in latin-1, utf8, and codepoint forms. Macros can be set to return
26 the length (in bytes) of the matched codepoint, or the codepoint itself.
28 To regenerate regcharclass.h, run this script from perl-root. No arguments
31 Using WHATEVER as an example the following macros will be produced:
35 =item is_WHATEVER(s,is_utf8)
37 =item is_WHATEVER_safe(s,e,is_utf8)
39 Do a lookup as appropriate based on the is_utf8 flag. When possible
40 comparisons involving octect<128 are done before checking the is_utf8
41 flag, hopefully saving time.
43 =item is_WHATEVER_utf8(s)
45 =item is_WHATEVER_utf8_safe(s,e)
47 Do a lookup assuming the string is encoded in (normalized) UTF8.
49 =item is_WHATEVER_latin1(s)
51 =item is_WHATEVER_latin1_safe(s,e)
53 Do a lookup assuming the string is encoded in latin-1 (aka plan octets).
55 =item is_WHATEVER_cp(cp)
57 Check to see if the string matches a given codepoint (hypothetically a
58 U32). The condition is constructed as as to "break out" as early as
59 possible if the codepoint is out of range of the condition.
63 (cp==X || (cp>X && (cp==Y || (cp>Y && ...))))
65 Thus if the character is X+1 only two comparisons will be done. Making
66 matching lookups slower, but non-matching faster.
70 Additionally it is possible to generate C<what_> variants that return
71 the codepoint read instead of the number of octets read, this can be
72 done by suffixing '-cp' to the type description.
76 perltidy -st -bt=1 -bbt=0 -pt=0 -sbt=1 -ce -nwls== "%f"
81 Author: Yves Orton (demerphq) 2007
85 No tests directly here (although the regex engine will fail tests
86 if this code is broken). Insufficient documentation and no Getopts
87 handler for using the module as a script.
91 You may distribute under the terms of either the GNU General Public
92 License or the Artistic License, as specified in the README file.
96 # Sub naming convention:
97 # __func : private subroutine, can not be called as a method
98 # _func : private method, not meant for external use
99 # func : public method.
102 #-------------------------------------------------------------------------------
104 # ($cp,$n,$l,$u)=__uni_latin($str);
106 # Return a list of arrays, each of which when interpreted correctly
107 # represent the string in some given encoding with specific conditions.
109 # $cp - list of codepoints that make up the string.
110 # $n - list of octets that make up the string if all codepoints < 128
111 # $l - list of octets that make up the string in latin1 encoding if all
112 # codepoints < 256, and at least one codepoint is >127.
113 # $u - list of octets that make up the string in utf8 if any codepoint >127
116 #-----------+----------
126 for my $ch ( split //, $str ) {
129 $max= $cp if $max < $cp;
135 $l= [@cp] if $max && $max < 256;
137 my $copy= $str; # must copy string, FB_CROAK makes encode destructive
138 $u= eval { Encode::encode( "utf8", $copy, Encode::FB_CROAK ) };
139 # $u is utf8 but with the utf8 flag OFF
140 # therefore "C*" gets us the values of the bytes involved.
141 $u= [ unpack "C*", $u ] if defined $u;
143 return ( \@cp, $n, $l, $u );
147 # $clean= __clean($expr);
149 # Cleanup a ternary expression, removing unnecessary parens and apply some
150 # simplifications using regexes.
156 $parens= qr/ (?> \( (?> (?: (?> [^()]+ ) | (??{ $parens }) )* ) \) ) /x;
158 #print "$parens\n$expr\n";
159 1 while $expr =~ s/ \( \s* ( $parens ) \s* \) /$1/gx;
160 1 while $expr =~ s/ \( \s* ($parens) \s* \? \s*
161 \( \s* ($parens) \s* \? \s* ($parens|[^:]+?) \s* : \s* ($parens|[^)]+?) \s* \)
162 \s* : \s* \4 \s* \)/( ( $1 && $2 ) ? $3 : 0 )/gx;
167 # $text= __macro(@args);
168 # Join args together by newlines, and then neatly add backslashes to the end
169 # of every line as expected by the C pre-processor for #define's.
173 my $str= join "\n", @_;
175 my @lines= map { s/\s+$//; s/\t/ /g; $_ } split /\n/, $str;
176 my $last= pop @lines;
177 $str= join "\n", ( map { sprintf "%-76s\\", $_ } @lines ), $last;
178 1 while $str =~ s/^(\t*) {8}/$1\t/gm;
183 # my $op=__incrdepth($op);
185 # take an 'op' hashref and add one to it and all its childrens depths.
190 return unless ref $op;
192 __incrdepth( $op->{yes} );
193 __incrdepth( $op->{no} );
197 # join two branches of an opcode together with a condition, incrementing
198 # the depth on the yes branch when we do so.
199 # returns the new root opcode of the tree.
201 my ( $cond, $yes, $no )= @_;
204 yes => __incrdepth( $yes ),
214 # my $obj=CLASS->new(op=>'SOMENAME',title=>'blah',txt=>[..]);
216 # Create a new CharClass::Matcher object by parsing the text in
217 # the txt array. Currently applies the following rules:
219 # Element starts with C<0x>, line is evaled the result treated as
220 # a number which is passed to chr().
222 # Element starts with C<">, line is evaled and the result treated
225 # Each string is then stored in the 'strs' subhash as a hash record
226 # made up of the results of __uni_latin1, using the keynames
227 # 'low','latin1','utf8', as well as the synthesized 'LATIN1' and
228 # 'UTF8' which hold a merge of 'low' and their lowercase equivelents.
230 # Size data is tracked per type in the 'size' subhash.
238 die "in " . __PACKAGE__ . " constructor '$_;' is a mandatory field"
244 title => $opt{title} || '',
246 foreach my $txt ( @{ $opt{txt} } ) {
248 if ( $str =~ /^[""]/ ) {
250 } elsif ( $str =~ /^0x/ ) {
253 die "Unparsable line: $txt\n";
257 my ( $cp, $low, $latin1, $utf8 )= __uni_latin1( $str );
258 my $UTF8= $low || $utf8;
259 my $LATIN1= $low || $latin1;
260 #die Dumper($txt,$cp,$low,$latin1,$utf8)
261 # if $txt=~/NEL/ or $utf8 and @$utf8>3;
263 @{ $self->{strs}{$str} }{qw( str txt low utf8 latin1 cp UTF8 LATIN1 )}=
264 ( $str, $txt, $low, $utf8, $latin1, $cp, $UTF8, $LATIN1 );
265 my $rec= $self->{strs}{$str};
266 foreach my $key ( qw(low utf8 latin1 cp UTF8 LATIN1) ) {
267 $self->{size}{$key}{ 0 + @{ $self->{strs}{$str}{$key} } }++
268 if $self->{strs}{$str}{$key};
270 $self->{has_multi} ||= @$cp > 1;
271 $self->{has_ascii} ||= $latin1 && @$latin1;
272 $self->{has_low} ||= $low && @$low;
273 $self->{has_high} ||= !$low && !$latin1;
275 $self->{val_fmt}= $hex_fmt;
276 $self->{count}= 0 + keys %{ $self->{strs} };
280 # my $trie = make_trie($type,$maxlen);
282 # using the data stored in the object build a trie of a specific type,
283 # and with specific maximum depth. The trie is made up the elements of
284 # the given types array for each string in the object (assuming it is
287 # returns the trie, or undef if there was no relevant data in the object.
291 my ( $self, $type, $maxlen )= @_;
293 my $strs= $self->{strs};
295 foreach my $rec ( values %$strs ) {
296 die "panic: unknown type '$type'"
297 if !exists $rec->{$type};
298 my $dat= $rec->{$type};
300 next if $maxlen && @$dat > $maxlen;
302 foreach my $elem ( @$dat ) {
303 $node->{$elem} ||= {};
304 $node= $node->{$elem};
306 $node->{''}= $rec->{str};
308 return 0 + keys( %trie ) ? \%trie : undef;
311 # my $optree= _optree()
313 # recursively convert a trie to an optree where every node represents
319 my ( $self, $trie, $test_type, $ret_type, $else, $depth )= @_;
320 return unless defined $trie;
321 if ( $self->{has_multi} and $ret_type =~ /cp|both/ ) {
322 die "Can't do 'cp' optree from multi-codepoint strings";
325 $else= 0 unless defined $else;
326 $depth= 0 unless defined $depth;
328 my @conds= sort { $a <=> $b } grep { length $_ } keys %$trie;
330 if ( $ret_type eq 'cp' ) {
331 $else= $self->{strs}{ $trie->{''} }{cp}[0];
332 $else= sprintf "$self->{val_fmt}", $else if $else > 9;
333 } elsif ( $ret_type eq 'len' ) {
335 } elsif ( $ret_type eq 'both') {
336 $else= $self->{strs}{ $trie->{''} }{cp}[0];
337 $else= sprintf "$self->{val_fmt}", $else if $else > 9;
338 $else= "len=$depth, $else";
341 return $else if !@conds;
344 my ( $yes_res, $as_code, @cond );
345 my $test= $test_type eq 'cp' ? "cp" : "((U8*)s)[$depth]";
347 $node->{vals}= [@cond];
348 $node->{test}= $test;
349 $node->{yes}= $yes_res;
350 $node->{depth}= $depth;
354 my $cond= shift @conds;
356 $self->_optree( $trie->{$cond}, $test_type, $ret_type, $else,
358 my $res_code= Dumper( $res );
359 if ( !$yes_res || $res_code ne $as_code ) {
364 ( $yes_res, $as_code )= ( $res, $res_code );
374 # my $optree= optree(%opts);
376 # Convert a trie to an optree, wrapper for _optree
381 my $trie= $self->make_trie( $opt{type}, $opt{max_depth} );
382 $opt{ret_type} ||= 'len';
383 my $test_type= $opt{type} eq 'cp' ? 'cp' : 'depth';
384 return $self->_optree( $trie, $test_type, $opt{ret_type}, $opt{else}, 0 );
387 # my $optree= generic_optree(%opts);
389 # build a "generic" optree out of the three 'low', 'latin1', 'utf8'
390 # sets of strings, including a branch for handling the string type check.
397 $opt{ret_type} ||= 'len';
398 my $test_type= 'depth';
399 my $else= $opt{else} || 0;
401 my $latin1= $self->make_trie( 'latin1', $opt{max_depth} );
402 my $utf8= $self->make_trie( 'utf8', $opt{max_depth} );
404 $_= $self->_optree( $_, $test_type, $opt{ret_type}, $else, 0 )
408 $else= __cond_join( "( is_utf8 )", $utf8, $latin1 || $else );
409 } elsif ( $latin1 ) {
410 $else= __cond_join( "!( is_utf8 )", $latin1, $else );
412 my $low= $self->make_trie( 'low', $opt{max_depth} );
414 $else= $self->_optree( $low, $test_type, $opt{ret_type}, $else, 0 );
422 # create a string length guarded optree.
428 my $type= $opt{type};
430 die "Can't do a length_optree on type 'cp', makes no sense."
433 my ( @size, $method );
435 if ( $type eq 'generic' ) {
436 $method= 'generic_optree';
438 %{ $self->{size}{low} || {} },
439 %{ $self->{size}{latin1} || {} },
440 %{ $self->{size}{utf8} || {} }
442 @size= sort { $a <=> $b } keys %sizes;
445 @size= sort { $a <=> $b } keys %{ $self->{size}{$type} };
448 my $else= ( $opt{else} ||= 0 );
449 for my $size ( @size ) {
450 my $optree= $self->$method( %opt, type => $type, max_depth => $size );
451 my $cond= "((e)-(s) > " . ( $size - 1 ).")";
452 $else= __cond_join( $cond, $optree, $else );
458 # turn a list of conditions into a text expression
459 # - merges ranges of conditions, and joins the result with ||
461 my ( $self, $op, $combine )= @_;
462 my $cond= $op->{vals};
463 my $test= $op->{test};
464 return "( $test )" if !defined $cond;
470 if ( $ranges[-1][0] == $ranges[-1][1] ) {
471 $ranges[-1]= $ranges[-1][0];
472 } elsif ( $ranges[-1][0] + 1 == $ranges[-1][1] ) {
473 $ranges[-1]= $ranges[-1][0];
474 push @ranges, $ranges[-1] + 1;
478 for my $cond ( @$cond ) {
479 if ( !@ranges || $cond != $ranges[-1][1] + 1 ) {
481 push @ranges, [ $cond, $cond ];
487 return $self->_combine( $test, @ranges )
492 "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
494 : sprintf( "$self->{val_fmt} == $test", $_ );
496 return "( " . join( " || ", @ranges ) . " )";
500 # recursively turn a list of conditions into a fast break-out condition
501 # used by _cond_as_str() for 'cp' type macros.
503 my ( $self, $test, @cond )= @_;
505 my $item= shift @cond;
509 sprintf( "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
511 $gtv= sprintf "$self->{val_fmt}", $item->[1];
513 $cstr= sprintf( "$self->{val_fmt} == $test", $item );
514 $gtv= sprintf "$self->{val_fmt}", $item;
517 return "( $cstr || ( $gtv < $test &&\n"
518 . $self->_combine( $test, @cond ) . " ) )";
525 # recursively convert an optree to text with reasonably neat formatting
527 my ( $self, $op, $combine, $brace )= @_;
531 my $cond= $self->_cond_as_str( $op, $combine );
532 my $yes= $self->_render( $op->{yes}, $combine, 1 );
533 my $no= $self->_render( $op->{no}, $combine, 0 );
534 return "( $cond )" if $yes eq '1' and $no eq '0';
535 my ( $lb, $rb )= $brace ? ( "( ", " )" ) : ( "", "" );
536 return "$lb$cond ? $yes : $no$rb"
537 if !ref( $op->{yes} ) && !ref( $op->{no} );
539 my $ind= "\n" . ( $ind1 x $op->{depth} );
541 if ( ref $op->{yes} ) {
542 $yes= $ind . $ind1 . $yes;
547 return "$lb$cond ?$yes$ind: $no$rb";
550 # $expr=render($op,$combine)
552 # convert an optree to text with reasonably neat formatting. If $combine
553 # is true then the condition is created using "fast breakouts" which
554 # produce uglier expressions that are more efficient for common case,
555 # longer lists such as that resulting from type 'cp' output.
556 # Currently only used for type 'cp' macros.
558 my ( $self, $op, $combine )= @_;
559 my $str= "( " . $self->_render( $op, $combine ) . " )";
560 return __clean( $str );
564 # make a macro of a given type.
565 # calls into make_trie and (generic_|length_)optree as needed
567 # type : 'cp','generic','low','latin1','utf8','LATIN1','UTF8'
568 # ret_type : 'cp' or 'len'
569 # safe : add length guards to macro
571 # type defaults to 'generic', and ret_type to 'len' unless type is 'cp'
572 # in which case it defaults to 'cp' as well.
574 # it is illegal to do a type 'cp' macro on a pattern with multi-codepoint
575 # sequences in it, as the generated macro will accept only a single codepoint
584 my $type= $opts{type} || 'generic';
585 die "Can't do a 'cp' on multi-codepoint character class '$self->{op}'"
587 and $self->{has_multi};
588 my $ret_type= $opts{ret_type} || ( $opts{type} eq 'cp' ? 'cp' : 'len' );
591 $method= 'length_optree';
592 } elsif ( $type eq 'generic' ) {
593 $method= 'generic_optree';
597 my $optree= $self->$method( %opts, type => $type, ret_type => $ret_type );
598 my $text= $self->render( $optree, $type eq 'cp' );
599 my @args= $type eq 'cp' ? 'cp' : 's';
600 push @args, "e" if $opts{safe};
601 push @args, "is_utf8" if $type eq 'generic';
602 push @args, "len" if $ret_type eq 'both';
603 my $pfx= $ret_type eq 'both' ? 'what_len_' :
604 $ret_type eq 'cp' ? 'what_' : 'is_';
605 my $ext= $type eq 'generic' ? '' : '_' . lc( $type );
606 $ext .= "_safe" if $opts{safe};
607 my $argstr= join ",", @args;
608 return "/*** GENERATED CODE ***/\n"
609 . __macro( "#define $pfx$self->{op}$ext($argstr)\n$text" );
612 # if we arent being used as a module (highly likely) then process
613 # the __DATA__ below and produce macros in regcharclass.h
614 # if an argument is provided to the script then it is assumed to
615 # be the path of the file to output to, if the arg is '-' outputs
619 my $path= shift @ARGV || "regcharclass.h";
621 if ( $path eq '-' ) {
624 $out_fh = open_new( $path );
626 print $out_fh read_only_top( lang => 'C', by => $0,
627 file => 'regcharclass.h', style => '*',
628 copyright => [2007, 2011] );
630 my ( $op, $title, @txt, @types, @mods );
633 print $out_fh "/*\n\t$op: $title\n\n";
634 print $out_fh join "\n", ( map { "\t$_" } @txt ), "*/", "";
635 my $obj= __PACKAGE__->new( op => $op, title => $title, txt => \@txt );
637 #die Dumper(\@types,\@mods);
639 foreach my $type_spec ( @types ) {
640 my ( $type, $ret )= split /-/, $type_spec;
642 foreach my $mod ( @mods ) {
643 next if $mod eq 'safe' and $type eq 'cp';
644 my $macro= $obj->make_macro(
647 safe => $mod eq 'safe'
649 print $out_fh $macro, "\n";
660 ( $op, $title )= split /\s*:\s*/, $_, 2;
662 } elsif ( s/^=>// ) {
663 my ( $type, $modifier )= split /:/, $_;
664 @types= split ' ', $type;
665 @mods= split ' ', $modifier;
672 print $out_fh "/* ex: set ro: */\n";
674 read_only_bottom_close_and_rename($out_fh)
679 # Valid types: generic, LATIN1, UTF8, low, latin1, utf8
680 # default return value is octects read.
681 # append -cp to make it codepoint matched.
682 # modifiers come after the colon, valid possibilities
683 # being 'fast' and 'safe'.
685 1; # in the unlikely case we are being used as a module
688 LNBREAK: Line Break: \R
689 => generic UTF8 LATIN1 :fast safe
690 "\x0D\x0A" # CRLF - Network (Windows) line ending
691 0x0A # LF | LINE FEED
692 0x0B # VT | VERTICAL TAB
693 0x0C # FF | FORM FEED
694 0x0D # CR | CARRIAGE RETURN
695 0x85 # NEL | NEXT LINE
696 0x2028 # LINE SEPARATOR
697 0x2029 # PARAGRAPH SEPARATOR
699 HORIZWS: Horizontal Whitespace: \h \H
700 => generic UTF8 LATIN1 cp :fast safe
704 0x1680 # OGHAM SPACE MARK
705 0x180e # MONGOLIAN VOWEL SEPARATOR
710 0x2004 # THREE-PER-EM SPACE
711 0x2005 # FOUR-PER-EM SPACE
712 0x2006 # SIX-PER-EM SPACE
713 0x2007 # FIGURE SPACE
714 0x2008 # PUNCTUATION SPACE
717 0x202f # NARROW NO-BREAK SPACE
718 0x205f # MEDIUM MATHEMATICAL SPACE
719 0x3000 # IDEOGRAPHIC SPACE
721 VERTWS: Vertical Whitespace: \v \V
722 => generic UTF8 LATIN1 cp :fast safe
728 0x2028 # LINE SEPARATOR
729 0x2029 # PARAGRAPH SEPARATOR
732 TRICKYFOLD: Problematic fold case letters. When adding to this list, also should add them to regcomp.c and fold_grind.t
733 => generic cp generic-cp generic-both :fast safe
734 0x00DF # LATIN SMALL LETTER SHARP S
735 0x0390 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
736 0x03B0 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
737 0x1E9E # LATIN CAPITAL LETTER SHARP S, because maps to same as 00DF
738 0x1FD3 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA; maps same as 0390
739 0x1FE3 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA; maps same as 03B0