1 package CharClass::Matcher;
4 use warnings FATAL => 'all';
5 use Text::Wrap qw(wrap);
8 $Data::Dumper::Useqq= 1;
9 our $hex_fmt= "0x%02X";
13 CharClass::Matcher -- Generate C macros that match character classes efficiently
17 perl Porting/regcharclass.pl
21 Dynamically generates macros for detecting special charclasses
22 in latin-1, utf8, and codepoint forms. Macros can be set to return
23 the length (in bytes) of the matched codepoint, or the codepoint itself.
25 To regenerate regcharclass.h, run this script from perl-root. No arguments
28 Using WHATEVER as an example the following macros will be produced:
32 =item is_WHATEVER(s,is_utf8)
34 =item is_WHATEVER_safe(s,e,is_utf8)
36 Do a lookup as appropriate based on the is_utf8 flag. When possible
37 comparisons involving octect<128 are done before checking the is_utf8
38 flag, hopefully saving time.
40 =item is_WHATEVER_utf8(s)
42 =item is_WHATEVER_utf8_safe(s,e)
44 Do a lookup assuming the string is encoded in (normalized) UTF8.
46 =item is_WHATEVER_latin1(s)
48 =item is_WHATEVER_latin1_safe(s,e)
50 Do a lookup assuming the string is encoded in latin-1 (aka plan octets).
52 =item is_WHATEVER_cp(cp)
54 Check to see if the string matches a given codepoint (hypotethically a
55 U32). The condition is constructed as as to "break out" as early as
56 possible if the codepoint is out of range of the condition.
60 (cp==X || (cp>X && (cp==Y || (cp>Y && ...))))
62 Thus if the character is X+1 only two comparisons will be done. Making
63 matching lookups slower, but non-matching faster.
67 Additionally it is possible to generate C<what_> variants that return
68 the codepoint read instead of the number of octets read, this can be
69 done by suffixing '-cp' to the type description.
73 perltidy -st -bt=1 -bbt=0 -pt=0 -sbt=1 -ce -nwls== "%f"
78 Author: Yves Orton (demerphq) 2007
82 No tests directly here (although the regex engine will fail tests
83 if this code is broken). Insufficient documentation and no Getopts
84 handler for using the module as a script.
88 You may distribute under the terms of either the GNU General Public
89 License or the Artistic License, as specified in the README file.
93 # Sub naming convention:
94 # __func : private subroutine, can not be called as a method
95 # _func : private method, not meant for external use
96 # func : public method.
99 #-------------------------------------------------------------------------------
101 # ($cp,$n,$l,$u)=__uni_latin($str);
103 # Return a list of arrays, each of which when interepreted correctly
104 # represent the string in some given encoding with specific conditions.
106 # $cp - list of codepoints that make up the string.
107 # $n - list of octets that make up the string if all codepoints < 128
108 # $l - list of octets that make up the string in latin1 encoding if all
109 # codepoints < 256, and at least one codepoint is >127.
110 # $u - list of octets that make up the string in utf8 if any codepoint >127
113 #-----------+----------
123 for my $ch ( split //, $str ) {
126 $max= $cp if $max < $cp;
132 $l= [@cp] if $max && $max < 256;
134 my $copy= $str; # must copy string, FB_CROAK makes encode destructive
135 $u= eval { Encode::encode( "utf8", $copy, Encode::FB_CROAK ) };
136 $u= [ unpack "U0C*", $u ] if $u;
138 return ( \@cp, $n, $l, $u );
142 # $clean= __clean($expr);
144 # Cleanup a ternary expression, removing unnecessary parens and apply some
145 # simplifications using regexes.
151 $parens= qr/ (?> \( (?> (?: (?> [^()]+ ) | (??{ $parens }) )* ) \) ) /x;
153 #print "$parens\n$expr\n";
154 1 while $expr =~ s/ \( \s* ( $parens ) \s* \) /$1/gx;
155 1 while $expr =~ s/ \( \s* ($parens) \s* \? \s*
156 \( \s* ($parens) \s* \? \s* ($parens|[^:]+?) \s* : \s* ($parens|[^)]+?) \s* \)
157 \s* : \s* \4 \s* \)/( ( $1 && $2 ) ? $3 : 0 )/gx;
162 # $text= __macro(@args);
163 # Join args together by newlines, and then neatly add backslashes to the end
164 # of every line as expected by the C pre-processor for #define's.
168 my $str= join "\n", @_;
170 my @lines= map { s/\s+$//; s/\t/ /g; $_ } split /\n/, $str;
171 my $last= pop @lines;
172 $str= join "\n", ( map { sprintf "%-76s\\", $_ } @lines ), $last;
173 1 while $str =~ s/^(\t*) {8}/$1\t/gm;
178 # my $op=__incrdepth($op);
180 # take an 'op' hashref and add one to it and all its childrens depths.
185 return unless ref $op;
187 __incrdepth( $op->{yes} );
188 __incrdepth( $op->{no} );
192 # join two branches of an opcode together with a condition, incrementing
193 # the depth on the yes branch when we do so.
194 # returns the new root opcode of the tree.
196 my ( $cond, $yes, $no )= @_;
199 yes => __incrdepth( $yes ),
209 # my $obj=CLASS->new(op=>'SOMENAME',title=>'blah',txt=>[..]);
211 # Create a new CharClass::Matcher object by parsing the text in
212 # the txt array. Currently applies the following rules:
214 # Element starts with C<0x>, line is evaled the result treated as
215 # a number which is passed to chr().
217 # Element starts with C<">, line is evaled and the result treated
220 # Each string is then stored in the 'strs' subhash as a hash record
221 # made up of the results of __uni_latin1, using the keynames
222 # 'low','latin1','utf8', as well as the synthesized 'LATIN1' and
223 # 'UTF8' which hold a merge of 'low' and their lowercase equivelents.
225 # Size data is tracked per type in the 'size' subhash.
233 die "in " . __PACKAGE__ . " constructor '$_;' is a mandatory field"
239 title => $opt{title} || '',
241 foreach my $txt ( @{ $opt{txt} } ) {
243 if ( $str =~ /^[""]/ ) {
245 } elsif ( $str =~ /^0x/ ) {
248 die "Unparseable line: $txt\n";
252 my ( $cp, $low, $latin1, $utf8 )= __uni_latin1( $str );
253 my $UTF8= $low || $utf8;
254 my $LATIN1= $low || $latin1;
256 @{ $self->{strs}{$str} }{qw( str txt low utf8 latin1 cp UTF8 LATIN1 )}=
257 ( $str, $txt, $low, $utf8, $latin1, $cp, $UTF8, $LATIN1 );
258 my $rec= $self->{strs}{$str};
259 foreach my $key ( qw(low utf8 latin1 cp UTF8 LATIN1) ) {
260 $self->{size}{$key}{ 0 + @{ $self->{strs}{$str}{$key} } }++
261 if $self->{strs}{$str}{$key};
263 $self->{has_multi} ||= @$cp > 1;
264 $self->{has_ascii} ||= $latin1 && @$latin1;
265 $self->{has_low} ||= $low && @$low;
266 $self->{has_high} ||= !$low && !$latin1;
268 $self->{val_fmt}= $hex_fmt;
269 $self->{count}= 0 + keys %{ $self->{strs} };
273 # my $trie = make_trie($type,$maxlen);
275 # using the data stored in the object build a trie of a specifc type,
276 # and with specific maximum depth. The trie is made up the elements of
277 # the given types array for each string in the object (assuming it is
280 # returns the trie, or undef if there was no relevent data in the object.
284 my ( $self, $type, $maxlen )= @_;
286 my $strs= $self->{strs};
288 foreach my $rec ( values %$strs ) {
289 die "panic: unknown type '$type'"
290 if !exists $rec->{$type};
291 my $dat= $rec->{$type};
293 next if $maxlen && @$dat > $maxlen;
295 foreach my $elem ( @$dat ) {
296 $node->{$elem} ||= {};
297 $node= $node->{$elem};
299 $node->{''}= $rec->{str};
301 return 0 + keys( %trie ) ? \%trie : undef;
304 # my $optree= _optree()
306 # recursively convert a trie to an optree where every node represents
312 my ( $self, $trie, $test_type, $ret_type, $else, $depth )= @_;
313 return unless defined $trie;
314 if ( $self->{has_multi} and $ret_type =~ /cp|both/ ) {
315 die "Can't do 'cp' optree from multi-codepoint strings";
318 $else= 0 unless defined $else;
319 $depth= 0 unless defined $depth;
321 my @conds= sort { $a <=> $b } grep { length $_ } keys %$trie;
323 if ( $ret_type eq 'cp' ) {
324 $else= $self->{strs}{ $trie->{''} }{cp}[0];
325 $else= sprintf "$self->{val_fmt}", $else if $else > 9;
326 } elsif ( $ret_type eq 'len' ) {
328 } elsif ( $ret_type eq 'both') {
329 $else= $self->{strs}{ $trie->{''} }{cp}[0];
330 $else= sprintf "$self->{val_fmt}", $else if $else > 9;
331 $else= "len=$depth, $else";
334 return $else if !@conds;
337 my ( $yes_res, $as_code, @cond );
338 my $test= $test_type eq 'cp' ? "cp" : "((U8*)s)[$depth]";
340 $node->{vals}= [@cond];
341 $node->{test}= $test;
342 $node->{yes}= $yes_res;
343 $node->{depth}= $depth;
347 my $cond= shift @conds;
349 $self->_optree( $trie->{$cond}, $test_type, $ret_type, $else,
351 my $res_code= Dumper( $res );
352 if ( !$yes_res || $res_code ne $as_code ) {
357 ( $yes_res, $as_code )= ( $res, $res_code );
367 # my $optree= optree(%opts);
369 # Convert a trie to an optree, wrapper for _optree
374 my $trie= $self->make_trie( $opt{type}, $opt{max_depth} );
375 $opt{ret_type} ||= 'len';
376 my $test_type= $opt{type} eq 'cp' ? 'cp' : 'depth';
377 return $self->_optree( $trie, $test_type, $opt{ret_type}, $opt{else}, 0 );
380 # my $optree= generic_optree(%opts);
382 # build a "generic" optree out of the three 'low', 'latin1', 'utf8'
383 # sets of strings, including a branch for handling the string type check.
390 $opt{ret_type} ||= 'len';
391 my $test_type= 'depth';
392 my $else= $opt{else} || 0;
394 my $latin1= $self->make_trie( 'latin1', $opt{max_depth} );
395 my $utf8= $self->make_trie( 'utf8', $opt{max_depth} );
397 $_= $self->_optree( $_, $test_type, $opt{ret_type}, $else, 0 )
401 $else= __cond_join( "( is_utf8 )", $utf8, $latin1 || $else );
402 } elsif ( $latin1 ) {
403 $else= __cond_join( "!( is_utf8 )", $latin1, $else );
405 my $low= $self->make_trie( 'low', $opt{max_depth} );
407 $else= $self->_optree( $low, $test_type, $opt{ret_type}, $else, 0 );
415 # create a string length guarded optree.
421 my $type= $opt{type};
423 die "Can't do a length_optree on type 'cp', makes no sense."
426 my ( @size, $method );
428 if ( $type eq 'generic' ) {
429 $method= 'generic_optree';
431 %{ $self->{size}{low} || {} },
432 %{ $self->{size}{latin1} || {} },
433 %{ $self->{size}{utf8} || {} }
435 @size= sort { $a <=> $b } keys %sizes;
438 @size= sort { $a <=> $b } keys %{ $self->{size}{$type} };
441 my $else= ( $opt{else} ||= 0 );
442 for my $size ( @size ) {
443 my $optree= $self->$method( %opt, type => $type, max_depth => $size );
444 my $cond= "((e)-(s) > " . ( $size - 1 ).")";
445 $else= __cond_join( $cond, $optree, $else );
451 # turn a list of conditions into a text expression
452 # - merges ranges of conditions, and joins the result with ||
454 my ( $self, $op, $combine )= @_;
455 my $cond= $op->{vals};
456 my $test= $op->{test};
457 return "( $test )" if !defined $cond;
463 if ( $ranges[-1][0] == $ranges[-1][1] ) {
464 $ranges[-1]= $ranges[-1][0];
465 } elsif ( $ranges[-1][0] + 1 == $ranges[-1][1] ) {
466 $ranges[-1]= $ranges[-1][0];
467 push @ranges, $ranges[-1] + 1;
471 for my $cond ( @$cond ) {
472 if ( !@ranges || $cond != $ranges[-1][1] + 1 ) {
474 push @ranges, [ $cond, $cond ];
480 return $self->_combine( $test, @ranges )
485 "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
487 : sprintf( "$self->{val_fmt} == $test", $_ );
489 return "( " . join( " || ", @ranges ) . " )";
493 # recursively turn a list of conditions into a fast break-out condition
494 # used by _cond_as_str() for 'cp' type macros.
496 my ( $self, $test, @cond )= @_;
498 my $item= shift @cond;
502 sprintf( "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
504 $gtv= sprintf "$self->{val_fmt}", $item->[1];
506 $cstr= sprintf( "$self->{val_fmt} == $test", $item );
507 $gtv= sprintf "$self->{val_fmt}", $item;
510 return "( $cstr || ( $gtv < $test &&\n"
511 . $self->_combine( $test, @cond ) . " ) )";
518 # recursively convert an optree to text with reasonably neat formatting
520 my ( $self, $op, $combine, $brace )= @_;
524 my $cond= $self->_cond_as_str( $op, $combine );
525 my $yes= $self->_render( $op->{yes}, $combine, 1 );
526 my $no= $self->_render( $op->{no}, $combine, 0 );
527 return "( $cond )" if $yes eq '1' and $no eq '0';
528 my ( $lb, $rb )= $brace ? ( "( ", " )" ) : ( "", "" );
529 return "$lb$cond ? $yes : $no$rb"
530 if !ref( $op->{yes} ) && !ref( $op->{no} );
532 my $ind= "\n" . ( $ind1 x $op->{depth} );
534 if ( ref $op->{yes} ) {
535 $yes= $ind . $ind1 . $yes;
540 return "$lb$cond ?$yes$ind: $no$rb";
543 # $expr=render($op,$combine)
545 # convert an optree to text with reasonably neat formatting. If $combine
546 # is true then the condition is created using "fast breakouts" which
547 # produce uglier expressions that are more efficient for common case,
548 # longer lists such as that resulting from type 'cp' output.
549 # Currently only used for type 'cp' macros.
551 my ( $self, $op, $combine )= @_;
552 my $str= "( " . $self->_render( $op, $combine ) . " )";
553 return __clean( $str );
557 # make a macro of a given type.
558 # calls into make_trie and (generic_|length_)optree as needed
560 # type : 'cp','generic','low','latin1','utf8','LATIN1','UTF8'
561 # ret_type : 'cp' or 'len'
562 # safe : add length guards to macro
564 # type defaults to 'generic', and ret_type to 'len' unless type is 'cp'
565 # in which case it defaults to 'cp' as well.
567 # it is illegal to do a type 'cp' macro on a pattern with multi-codepoint
568 # sequences in it, as the generated macro will accept only a single codepoint
577 my $type= $opts{type} || 'generic';
578 die "Can't do a 'cp' on multi-codepoint character class '$self->{op}'"
580 and $self->{has_multi};
581 my $ret_type= $opts{ret_type} || ( $opts{type} eq 'cp' ? 'cp' : 'len' );
584 $method= 'length_optree';
585 } elsif ( $type eq 'generic' ) {
586 $method= 'generic_optree';
590 my $optree= $self->$method( %opts, type => $type, ret_type => $ret_type );
591 my $text= $self->render( $optree, $type eq 'cp' );
592 my @args= $type eq 'cp' ? 'cp' : 's';
593 push @args, "e" if $opts{safe};
594 push @args, "is_utf8" if $type eq 'generic';
595 push @args, "len" if $ret_type eq 'both';
596 my $pfx= $ret_type eq 'both' ? 'what_len_' :
597 $ret_type eq 'cp' ? 'what_' : 'is_';
598 my $ext= $type eq 'generic' ? '' : '_' . lc( $type );
599 $ext .= "_safe" if $opts{safe};
600 my $argstr= join ",", @args;
601 return "/*** GENERATED CODE ***/\n"
602 . __macro( "#define $pfx$self->{op}$ext($argstr)\n$text" );
605 # if we arent being used as a module (highly likely) then process
606 # the __DATA__ below and produce macros in regcharclass.h
607 # if an argument is provided to the script then it is assumed to
608 # be the path of the file to output to, if the arg is '-' outputs
615 my $path= shift @ARGV;
618 $path= "regcharclass.h";
619 if ( !-e $path ) { $path= "../$path" }
620 if ( !-e $path ) { die "Can't find '$path' to update!\n" }
623 if ( $path eq '-' ) {
626 rename $path, "$path.bak";
627 open $out_fh, ">", $path
628 or die "Can't write to '$path':$!";
629 binmode $out_fh; # want unix line endings even when run on win32.
631 my ( $zero )= $0 =~ /([^\\\/]+)$/;
632 print $out_fh <<"HEADER";
633 /* -*- buffer-read-only: t -*-
637 * Copyright (C) 2007, by Larry Wall and others
639 * You may distribute under the terms of either the GNU General Public
640 * License or the Artistic License, as specified in the README file.
642 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
643 * This file is built by Porting/$zero.
644 * (Generated at: @{[ scalar gmtime ]} GMT)
645 * Any changes made here will be lost!
650 my ( $op, $title, @txt, @types, @mods );
653 print $out_fh "/*\n\t$op: $title\n\n";
654 print $out_fh join "\n", ( map { "\t$_" } @txt ), "*/", "";
655 my $obj= __PACKAGE__->new( op => $op, title => $title, txt => \@txt );
657 #die Dumper(\@types,\@mods);
659 foreach my $type_spec ( @types ) {
660 my ( $type, $ret )= split /-/, $type_spec;
662 foreach my $mod ( @mods ) {
663 next if $mod eq 'safe' and $type eq 'cp';
664 my $macro= $obj->make_macro(
667 safe => $mod eq 'safe'
669 print $out_fh $macro, "\n";
680 ( $op, $title )= split /\s*:\s*/, $_, 2;
682 } elsif ( s/^=>// ) {
683 my ( $type, $modifier )= split /:/, $_;
684 @types= split ' ', $type;
685 @mods= split ' ', $modifier;
691 print $out_fh "/* ex: set ro: */\n";
692 print "updated $path\n" if $path ne '-';
696 # Valid types: generic, LATIN1, UTF8, low, latin1, utf8
697 # default return value is octects read.
698 # append -cp to make it codepoint matched.
699 # modifiers come after the colon, valid possibilities
700 # being 'fast' and 'safe'.
702 1; # in the unlikely case we are being used as a module
705 LNBREAK: Line Break: \R
706 => generic UTF8 LATIN1 :fast safe
707 "\x0D\x0A" # CRLF - Network (Windows) line ending
708 0x0A # LF | LINE FEED
709 0x0B # VT | VERTICAL TAB
710 0x0C # FF | FORM FEED
711 0x0D # CR | CARRIAGE RETURN
712 0x85 # NEL | NEXT LINE
713 0x2028 # LINE SEPARATOR
714 0x2029 # PARAGRAPH SEPARATOR
716 HORIZWS: Horizontal Whitespace: \h \H
717 => generic UTF8 LATIN1 cp :fast safe
721 0x1680 # OGHAM SPACE MARK
722 0x180e # MONGOLIAN VOWEL SEPARATOR
727 0x2004 # THREE-PER-EM SPACE
728 0x2005 # FOUR-PER-EM SPACE
729 0x2006 # SIX-PER-EM SPACE
730 0x2007 # FIGURE SPACE
731 0x2008 # PUNCTUATION SPACE
734 0x202f # NARROW NO-BREAK SPACE
735 0x205f # MEDIUM MATHEMATICAL SPACE
736 0x3000 # IDEOGRAPHIC SPACE
738 VERTWS: Vertical Whitespace: \v \V
739 => generic UTF8 LATIN1 cp :fast safe
745 0x2028 # LINE SEPARATOR
746 0x2029 # PARAGRAPH SEPARATOR
749 TRICKYFOLD: Problematic fold case letters.
750 => generic cp generic-cp generic-both :fast safe
751 0x00DF # LATIN1 SMALL LETTER SHARP S
752 0x0390 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
753 0x03B0 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS