File: regcharclass.pl

package info (click to toggle)
perl 5.24.1-3+deb9u5
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 103,716 kB
  • sloc: perl: 559,611; ansic: 293,886; sh: 67,316; pascal: 7,632; cpp: 3,895; makefile: 2,436; xml: 2,410; yacc: 989; sed: 6; lisp: 1
file content (1700 lines) | stat: -rwxr-xr-x 66,757 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
#!perl
package CharClass::Matcher;
use strict;
use 5.008;
use warnings;
use warnings FATAL => 'all';
use Data::Dumper;
$Data::Dumper::Useqq= 1;
our $hex_fmt= "0x%02X";

sub DEBUG () { 0 }
$|=1 if DEBUG;

require 'regen/regen_lib.pl';
require 'regen/charset_translations.pl';
require "regen/regcharclass_multi_char_folds.pl";

=head1 NAME

CharClass::Matcher -- Generate C macros that match character classes efficiently

=head1 SYNOPSIS

    perl Porting/regcharclass.pl

=head1 DESCRIPTION

Dynamically generates macros for detecting special charclasses
in latin-1, utf8, and codepoint forms. Macros can be set to return
the length (in bytes) of the matched codepoint, and/or the codepoint itself.

To regenerate F<regcharclass.h>, run this script from perl-root. No arguments
are necessary.

Using WHATEVER as an example the following macros can be produced, depending
on the input parameters (how to get each is described by internal comments at
the C<__DATA__> line):

=over 4

=item C<is_WHATEVER(s,is_utf8)>

=item C<is_WHATEVER_safe(s,e,is_utf8)>

Do a lookup as appropriate based on the C<is_utf8> flag. When possible
comparisons involving octect<128 are done before checking the C<is_utf8>
flag, hopefully saving time.

The version without the C<_safe> suffix should be used only when the input is
known to be well-formed.

=item C<is_WHATEVER_utf8(s)>

=item C<is_WHATEVER_utf8_safe(s,e)>

Do a lookup assuming the string is encoded in (normalized) UTF8.

The version without the C<_safe> suffix should be used only when the input is
known to be well-formed.

=item C<is_WHATEVER_latin1(s)>

=item C<is_WHATEVER_latin1_safe(s,e)>

Do a lookup assuming the string is encoded in latin-1 (aka plan octets).

The version without the C<_safe> suffix should be used only when it is known
that C<s> contains at least one character.

=item C<is_WHATEVER_cp(cp)>

Check to see if the string matches a given codepoint (hypothetically a
U32). The condition is constructed as to "break out" as early as
possible if the codepoint is out of range of the condition.

IOW:

  (cp==X || (cp>X && (cp==Y || (cp>Y && ...))))

Thus if the character is X+1 only two comparisons will be done. Making
matching lookups slower, but non-matching faster.

=item C<what_len_WHATEVER_FOO(arg1, ..., len)>

A variant form of each of the macro types described above can be generated, in
which the code point is returned by the macro, and an extra parameter (in the
final position) is added, which is a pointer for the macro to set the byte
length of the returned code point.

These forms all have a C<what_len> prefix instead of the C<is_>, for example
C<what_len_WHATEVER_safe(s,e,is_utf8,len)> and
C<what_len_WHATEVER_utf8(s,len)>.

These forms should not be used I<except> on small sets of mostly widely
separated code points; otherwise the code generated is inefficient.  For these
cases, it is best to use the C<is_> forms, and then find the code point with
C<utf8_to_uvchr_buf>().  This program can fail with a "deep recursion"
message on the worst of the inappropriate sets.  Examine the generated macro
to see if it is acceptable.

=item C<what_WHATEVER_FOO(arg1, ...)>

A variant form of each of the C<is_> macro types described above can be generated, in
which the code point and not the length is returned by the macro.  These have
the same caveat as L</what_len_WHATEVER_FOO(arg1, ..., len)>, plus they should
not be used where the set contains a NULL, as 0 is returned for two different
cases: a) the set doesn't include the input code point; b) the set does
include it, and it is a NULL.

=back

The above isn't quite complete, as for specialized purposes one can get a
macro like C<is_WHATEVER_utf8_no_length_checks(s)>, which assumes that it is
already known that there is enough space to hold the character starting at
C<s>, but otherwise checks that it is well-formed.  In other words, this is
intermediary in checking between C<is_WHATEVER_utf8(s)> and
C<is_WHATEVER_utf8_safe(s,e)>.

=head2 CODE FORMAT

perltidy  -st -bt=1 -bbt=0 -pt=0 -sbt=1 -ce -nwls== "%f"


=head1 AUTHOR

Author: Yves Orton (demerphq) 2007.  Maintained by Perl5 Porters.

=head1 BUGS

No tests directly here (although the regex engine will fail tests
if this code is broken). Insufficient documentation and no Getopts
handler for using the module as a script.

=head1 LICENSE

You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the README file.

=cut

# Sub naming convention:
# __func : private subroutine, can not be called as a method
# _func  : private method, not meant for external use
# func   : public method.

# private subs
#-------------------------------------------------------------------------------
#
# ($cp,$n,$l,$u)=__uni_latin($str);
#
# Return a list of arrays, each of which when interpreted correctly
# represent the string in some given encoding with specific conditions.
#
# $cp - list of codepoints that make up the string.
# $n  - list of octets that make up the string if all codepoints are invariant
#       regardless of if the string is in UTF-8 or not.
# $l  - list of octets that make up the string in latin1 encoding if all
#       codepoints < 256, and at least one codepoint is UTF-8 variant.
# $u  - list of octets that make up the string in utf8 if any codepoint is
#       UTF-8 variant
#
#   High CP | Defined
#-----------+----------
#   0 - 127 : $n            (127/128 are the values for ASCII platforms)
# 128 - 255 : $l, $u
# 256 - ... : $u
#

sub __uni_latin1 {
    my $charset= shift;
    my $str= shift;
    my $max= 0;
    my @cp;
    my @cp_high;
    my $only_has_invariants = 1;
    my $a2n = get_a2n($charset);
    for my $ch ( split //, $str ) {
        my $cp= ord $ch;
        $max= $cp if $max < $cp;
        if ($cp > 255) {
            push @cp, $cp;
            push @cp_high, $cp;
        }
        else {
            push @cp, $a2n->[$cp];
        }
    }
    my ( $n, $l, $u );
    $only_has_invariants = ($charset =~ /ascii/i) ? $max < 128 : $max < 160;
    if ($only_has_invariants) {
        $n= [@cp];
    } else {
        $l= [@cp] if $max && $max < 256;

        my @u;
        for my $ch ( split //, $str ) {
            push @u, map { ord } split //, cp_2_utfbytes(ord $ch, $charset);
        }
        $u = \@u;
    }
    return ( \@cp, \@cp_high, $n, $l, $u );
}

#
# $clean= __clean($expr);
#
# Cleanup a ternary expression, removing unnecessary parens and apply some
# simplifications using regexes.
#

sub __clean {
    my ( $expr )= @_;

    #return $expr;

    our $parens;
    $parens= qr/ (?> \( (?> (?: (?> [^()]+ ) | (??{ $parens }) )* ) \) ) /x;

    ## remove redundant parens
    1 while $expr =~ s/ \( \s* ( $parens ) \s* \) /$1/gx;


    # repeatedly simplify conditions like
    #       ( (cond1) ? ( (cond2) ? X : Y ) : Y )
    # into
    #       ( ( (cond1) && (cond2) ) ? X : Y )
    # Also similarly handles expressions like:
    #       : (cond1) ? ( (cond2) ? X : Y ) : Y )
    # Note the inclusion of the close paren in ([:()]) and the open paren in ([()]) is
    # purely to ensure we have a balanced set of parens in the expression which makes
    # it easier to understand the pattern in an editor that understands paren's, we do
    # not expect either of these cases to actually fire. - Yves
    1 while $expr =~ s/
        ([:()])  \s*
            ($parens) \s*
            \? \s*
                \( \s* ($parens) \s*
                    \? \s* ($parens|[^()?:\s]+?) \s*
                    :  \s* ($parens|[^()?:\s]+?) \s*
                \) \s*
            : \s* \5 \s*
        ([()])
    /$1 ( $2 && $3 ) ? $4 : $5 $6/gx;
    #$expr=~s/\(\(U8\*\)s\)\[(\d+)\]/S$1/g if length $expr > 8000;
    #$expr=~s/\s+//g if length $expr > 8000;

    die "Expression too long" if length $expr > 8000;

    return $expr;
}

#
# $text= __macro(@args);
# Join args together by newlines, and then neatly add backslashes to the end
# of every  line as expected by the C pre-processor for #define's.
#

sub __macro {
    my $str= join "\n", @_;
    $str =~ s/\s*$//;
    my @lines= map { s/\s+$//; s/\t/        /g; $_ } split /\n/, $str;
    my $last= pop @lines;
    $str= join "\n", ( map { sprintf "%-76s\\", $_ } @lines ), $last;
    1 while $str =~ s/^(\t*) {8}/$1\t/gm;
    return $str . "\n";
}

#
# my $op=__incrdepth($op);
#
# take an 'op' hashref and add one to it and all its childrens depths.
#

sub __incrdepth {
    my $op= shift;
    return unless ref $op;
    $op->{depth} += 1;
    __incrdepth( $op->{yes} );
    __incrdepth( $op->{no} );
    return $op;
}

# join two branches of an opcode together with a condition, incrementing
# the depth on the yes branch when we do so.
# returns the new root opcode of the tree.
sub __cond_join {
    my ( $cond, $yes, $no )= @_;
    if (ref $yes) {
        return {
            test  => $cond,
            yes   => __incrdepth( $yes ),
            no    => $no,
            depth => 0,
        };
    }
    else {
        return {
            test  => $cond,
            yes   => $yes,
            no    => __incrdepth($no),
            depth => 0,
        };
    }
}

# Methods

# constructor
#
# my $obj=CLASS->new(op=>'SOMENAME',title=>'blah',txt=>[..]);
#
# Create a new CharClass::Matcher object by parsing the text in
# the txt array. Currently applies the following rules:
#
# Element starts with C<0x>, line is evaled the result treated as
# a number which is passed to chr().
#
# Element starts with C<">, line is evaled and the result treated
# as a string.
#
# Each string is then stored in the 'strs' subhash as a hash record
# made up of the results of __uni_latin1, using the keynames
# 'low','latin1','utf8', as well as the synthesized 'LATIN1', 'high', and
# 'UTF8' which hold a merge of 'low' and their lowercase equivalents.
#
# Size data is tracked per type in the 'size' subhash.
#
# Return an object
#
sub new {
    my $class= shift;
    my %opt= @_;
    for ( qw(op txt) ) {
        die "in " . __PACKAGE__ . " constructor '$_;' is a mandatory field"
          if !exists $opt{$_};
    }

    my $self= bless {
        op    => $opt{op},
        title => $opt{title} || '',
    }, $class;
    foreach my $txt ( @{ $opt{txt} } ) {
        my $str= $txt;
        if ( $str =~ /^[""]/ ) {
            $str= eval $str;
        } elsif ($str =~ / - /x ) { # A range:  Replace this element on the
                                    # list with its expansion
            my ($lower, $upper) = $str =~ / 0x (.+?) \s* - \s* 0x (.+) /x;
            die "Format must be like '0xDEAD - 0xBEAF'; instead was '$str'" if ! defined $lower || ! defined $upper;
            foreach my $cp (hex $lower .. hex $upper) {
                push @{$opt{txt}}, sprintf "0x%X", $cp;
            }
            next;
        } elsif ($str =~ s/ ^ N (?= 0x ) //x ) {
            # Otherwise undocumented, a leading N means is already in the
            # native character set; don't convert.
            $str= chr eval $str;
        } elsif ( $str =~ /^0x/ ) {
            $str= eval $str;
            $str = chr $str;
        } elsif ( $str =~ / \s* \\p \{ ( .*? ) \} /x) {
            my $property = $1;
            use Unicode::UCD qw(prop_invlist);

            my @invlist = prop_invlist($property, '_perl_core_internal_ok');
            if (! @invlist) {

                # An empty return could mean an unknown property, or merely
                # that it is empty.  Call in scalar context to differentiate
                my $count = prop_invlist($property, '_perl_core_internal_ok');
                die "$property not found" unless defined $count;
            }

            # Replace this element on the list with the property's expansion
            for (my $i = 0; $i < @invlist; $i += 2) {
                foreach my $cp ($invlist[$i] .. $invlist[$i+1] - 1) {

                    # prop_invlist() returns native values; add leading 'N'
                    # to indicate that.
                    push @{$opt{txt}}, sprintf "N0x%X", $cp;
                }
            }
            next;
        } elsif ($str =~ / ^ do \s+ ( .* ) /x) {
            die "do '$1' failed: $!$@" if ! do $1 or $@;
            next;
        } elsif ($str =~ / ^ & \s* ( .* ) /x) { # user-furnished sub() call
            my @results = eval "$1";
            die "eval '$1' failed: $@" if $@;
            push @{$opt{txt}}, @results;
            next;
        } else {
            die "Unparsable line: $txt\n";
        }
        my ( $cp, $cp_high, $low, $latin1, $utf8 )= __uni_latin1( $opt{charset}, $str );
        my $UTF8= $low   || $utf8;
        my $LATIN1= $low || $latin1;
        my $high = (scalar grep { $_ < 256 } @$cp) ? 0 : $utf8;
        #die Dumper($txt,$cp,$low,$latin1,$utf8)
        #    if $txt=~/NEL/ or $utf8 and @$utf8>3;

        @{ $self->{strs}{$str} }{qw( str txt low utf8 latin1 high cp cp_high UTF8 LATIN1 )}=
          ( $str, $txt, $low, $utf8, $latin1, $high, $cp, $cp_high, $UTF8, $LATIN1 );
        my $rec= $self->{strs}{$str};
        foreach my $key ( qw(low utf8 latin1 high cp cp_high UTF8 LATIN1) ) {
            $self->{size}{$key}{ 0 + @{ $self->{strs}{$str}{$key} } }++
              if $self->{strs}{$str}{$key};
        }
        $self->{has_multi} ||= @$cp > 1;
        $self->{has_ascii} ||= $latin1 && @$latin1;
        $self->{has_low}   ||= $low && @$low;
        $self->{has_high}  ||= !$low && !$latin1;
    }
    $self->{val_fmt}= $hex_fmt;
    $self->{count}= 0 + keys %{ $self->{strs} };
    return $self;
}

# my $trie = make_trie($type,$maxlen);
#
# using the data stored in the object build a trie of a specific type,
# and with specific maximum depth. The trie is made up the elements of
# the given types array for each string in the object (assuming it is
# not too long.)
#
# returns the trie, or undef if there was no relevant data in the object.
#

sub make_trie {
    my ( $self, $type, $maxlen )= @_;

    my $strs= $self->{strs};
    my %trie;
    foreach my $rec ( values %$strs ) {
        die "panic: unknown type '$type'"
          if !exists $rec->{$type};
        my $dat= $rec->{$type};
        next unless $dat;
        next if $maxlen && @$dat > $maxlen;
        my $node= \%trie;
        foreach my $elem ( @$dat ) {
            $node->{$elem} ||= {};
            $node= $node->{$elem};
        }
        $node->{''}= $rec->{str};
    }
    return 0 + keys( %trie ) ? \%trie : undef;
}

sub pop_count ($) {
    my $word = shift;

    # This returns a list of the positions of the bits in the input word that
    # are 1.

    my @positions;
    my $position = 0;
    while ($word) {
        push @positions, $position if $word & 1;
        $position++;
        $word >>= 1;
    }
    return @positions;
}

# my $optree= _optree()
#
# recursively convert a trie to an optree where every node represents
# an if else branch.
#
#

sub _optree {
    my ( $self, $trie, $test_type, $ret_type, $else, $depth )= @_;
    return unless defined $trie;
    if ( $self->{has_multi} and $ret_type =~ /cp|both/ ) {
        die "Can't do 'cp' optree from multi-codepoint strings";
    }
    $ret_type ||= 'len';
    $else= 0  unless defined $else;
    $depth= 0 unless defined $depth;

    # if we have an empty string as a key it means we are in an
    # accepting state and unless we can match further on should
    # return the value of the '' key.
    if (exists $trie->{''} ) {
        # we can now update the "else" value, anything failing to match
        # after this point should return the value from this.
        if ( $ret_type eq 'cp' ) {
            $else= $self->{strs}{ $trie->{''} }{cp}[0];
            $else= sprintf "$self->{val_fmt}", $else if $else > 9;
        } elsif ( $ret_type eq 'len' ) {
            $else= $depth;
        } elsif ( $ret_type eq 'both') {
            $else= $self->{strs}{ $trie->{''} }{cp}[0];
            $else= sprintf "$self->{val_fmt}", $else if $else > 9;
            $else= "len=$depth, $else";
        }
    }
    # extract the meaningful keys from the trie, filter out '' as
    # it means we are an accepting state (end of sequence).
    my @conds= sort { $a <=> $b } grep { length $_ } keys %$trie;

    # if we haven't any keys there is no further we can match and we
    # can return the "else" value.
    return $else if !@conds;

    my $test = $test_type =~ /^cp/ ? "cp" : "((U8*)s)[$depth]";

    # First we loop over the possible keys/conditions and find out what they
    # look like; we group conditions with the same optree together.
    my %dmp_res;
    my @res_order;
    local $Data::Dumper::Sortkeys=1;
    foreach my $cond ( @conds ) {

        # get the optree for this child/condition
        my $res= $self->_optree( $trie->{$cond}, $test_type, $ret_type, $else, $depth + 1 );
        # convert it to a string with Dumper
        my $res_code= Dumper( $res );

        push @{$dmp_res{$res_code}{vals}}, $cond;
        if (!$dmp_res{$res_code}{optree}) {
            $dmp_res{$res_code}{optree}= $res;
            push @res_order, $res_code;
        }
    }

    # now that we have deduped the optrees we construct a new optree containing the merged
    # results.
    my %root;
    my $node= \%root;
    foreach my $res_code_idx (0 .. $#res_order) {
        my $res_code= $res_order[$res_code_idx];
        $node->{vals}= $dmp_res{$res_code}{vals};
        $node->{test}= $test;
        $node->{yes}= $dmp_res{$res_code}{optree};
        $node->{depth}= $depth;
        if ($res_code_idx < $#res_order) {
            $node= $node->{no}= {};
        } else {
            $node->{no}= $else;
        }
    }

    # return the optree.
    return \%root;
}

# my $optree= optree(%opts);
#
# Convert a trie to an optree, wrapper for _optree

sub optree {
    my $self= shift;
    my %opt= @_;
    my $trie= $self->make_trie( $opt{type}, $opt{max_depth} );
    $opt{ret_type} ||= 'len';
    my $test_type= $opt{type} =~ /^cp/ ? 'cp' : 'depth';
    return $self->_optree( $trie, $test_type, $opt{ret_type}, $opt{else}, 0 );
}

# my $optree= generic_optree(%opts);
#
# build a "generic" optree out of the three 'low', 'latin1', 'utf8'
# sets of strings, including a branch for handling the string type check.
#

sub generic_optree {
    my $self= shift;
    my %opt= @_;

    $opt{ret_type} ||= 'len';
    my $test_type= 'depth';
    my $else= $opt{else} || 0;

    my $latin1= $self->make_trie( 'latin1', $opt{max_depth} );
    my $utf8= $self->make_trie( 'utf8',     $opt{max_depth} );

    $_= $self->_optree( $_, $test_type, $opt{ret_type}, $else, 0 )
      for $latin1, $utf8;

    if ( $utf8 ) {
        $else= __cond_join( "( is_utf8 )", $utf8, $latin1 || $else );
    } elsif ( $latin1 ) {
        $else= __cond_join( "!( is_utf8 )", $latin1, $else );
    }
    if ($opt{type} eq 'generic') {
        my $low= $self->make_trie( 'low', $opt{max_depth} );
        if ( $low ) {
            $else= $self->_optree( $low, $test_type, $opt{ret_type}, $else, 0 );
        }
    }

    return $else;
}

# length_optree()
#
# create a string length guarded optree.
#

sub length_optree {
    my $self= shift;
    my %opt= @_;
    my $type= $opt{type};

    die "Can't do a length_optree on type 'cp', makes no sense."
      if $type =~ /^cp/;

    my $else= ( $opt{else} ||= 0 );

    return $else if $self->{count} == 0;

    my $method = $type =~ /generic/ ? 'generic_optree' : 'optree';
    if ($method eq 'optree' && scalar keys %{$self->{size}{$type}} == 1) {

        # Here is non-generic output (meaning that we are only generating one
        # type), and all things that match have the same number ('size') of
        # bytes.  The length guard is simply that we have that number of
        # bytes.
        my @size = keys %{$self->{size}{$type}};
        my $cond= "((e) - (s)) >= $size[0]";
        my $optree = $self->$method(%opt);
        $else= __cond_join( $cond, $optree, $else );
    }
    elsif ($self->{has_multi}) {
        my @size;

        # Here, there can be a match of a multiple character string.  We use
        # the traditional method which is to have a branch for each possible
        # size (longest first) and test for the legal values for that size.
        my %sizes= (
            %{ $self->{size}{low}    || {} },
            %{ $self->{size}{latin1} || {} },
            %{ $self->{size}{utf8}   || {} }
        );
        if ($method eq 'generic_optree') {
            @size= sort { $a <=> $b } keys %sizes;
        } else {
            @size= sort { $a <=> $b } keys %{ $self->{size}{$type} };
        }
        for my $size ( @size ) {
            my $optree= $self->$method( %opt, type => $type, max_depth => $size );
            my $cond= "((e)-(s) > " . ( $size - 1 ).")";
            $else= __cond_join( $cond, $optree, $else );
        }
    }
    else {
        my $utf8;

        # Here, has more than one possible size, and only matches a single
        # character.  For non-utf8, the needed length is 1; for utf8, it is
        # found by array lookup 'UTF8SKIP'.

        # If want just the code points above 255, set up to look for those;
        # otherwise assume will be looking for all non-UTF-8-invariant code
        # poiints.
        my $trie_type = ($type eq 'high') ? 'high' : 'utf8';

        # If we do want more than the 0-255 range, find those, and if they
        # exist...
        if ($opt{type} !~ /latin1/i && ($utf8 = $self->make_trie($trie_type, 0))) {

            # ... get them into an optree, and set them up as the 'else' clause
            $utf8 = $self->_optree( $utf8, 'depth', $opt{ret_type}, 0, 0 );

            # We could make this
            #   UTF8_IS_START(*s) && ((e) - (s)) >= UTF8SKIP(s))";
            # to avoid doing the UTF8SKIP and subsequent branches for invariants
            # that don't match.  But the current macros that get generated
            # have only a few things that can match past this, so I (khw)
            # don't think it is worth it.  (Even better would be to use
            # calculate_mask(keys %$utf8) instead of UTF8_IS_START, and use it
            # if it saves a bunch.  We assume that input text likely to be
            # well-formed .
            my $cond = "LIKELY(((e) - (s)) >= UTF8SKIP(s))";
            $else = __cond_join($cond, $utf8, $else);

            # For 'generic', we also will want the latin1 UTF-8 variants for
            # the case where the input isn't UTF-8.
            my $latin1;
            if ($method eq 'generic_optree') {
                $latin1 = $self->make_trie( 'latin1', 1);
                $latin1= $self->_optree( $latin1, 'depth', $opt{ret_type}, 0, 0 );
            }

            # If we want the UTF-8 invariants, get those.
            my $low;
            if ($opt{type} !~ /non_low|high/
                && ($low= $self->make_trie( 'low', 1)))
            {
                $low= $self->_optree( $low, 'depth', $opt{ret_type}, 0, 0 );

                # Expand out the UTF-8 invariants as a string so that we
                # can use them as the conditional
                $low = $self->_cond_as_str( $low, 0, \%opt);

                # If there are Latin1 variants, add a test for them.
                if ($latin1) {
                    $else = __cond_join("(! is_utf8 )", $latin1, $else);
                }
                elsif ($method eq 'generic_optree') {

                    # Otherwise for 'generic' only we know that what
                    # follows must be valid for just UTF-8 strings,
                    $else->{test} = "( is_utf8 && $else->{test} )";
                }

                # If the invariants match, we are done; otherwise we have
                # to go to the 'else' clause.
                $else = __cond_join($low, 1, $else);
            }
            elsif ($latin1) {   # Here, didn't want or didn't have invariants,
                                # but we do have latin variants
                $else = __cond_join("(! is_utf8)", $latin1, $else);
            }

            # We need at least one byte available to start off the tests
            $else = __cond_join("LIKELY((e) > (s))", $else, 0);
        }
        else {  # Here, we don't want or there aren't any variants.  A single
                # byte available is enough.
            my $cond= "((e) > (s))";
            my $optree = $self->$method(%opt);
            $else= __cond_join( $cond, $optree, $else );
        }
    }

    return $else;
}

sub calculate_mask(@) {
    # Look at the input list of byte values.  This routine returns an array of
    # mask/base pairs to generate that list.

    my @list = @_;
    my $list_count = @list;

    # Consider a set of byte values, A, B, C ....  If we want to determine if
    # <c> is one of them, we can write c==A || c==B || c==C ....  If the
    # values are consecutive, we can shorten that to A<=c && c<=Z, which uses
    # far fewer branches.  If only some of them are consecutive we can still
    # save some branches by creating range tests for just those that are
    # consecutive. _cond_as_str() does this work for looking for ranges.
    #
    # Another approach is to look at the bit patterns for A, B, C .... and see
    # if they have some commonalities.  That's what this function does.  For
    # example, consider a set consisting of the bytes
    # 0xF0, 0xF1, 0xF2, and 0xF3.  We could write:
    #   0xF0 <= c && c <= 0xF4
    # But the following mask/compare also works, and has just one test:
    #   (c & 0xFC) == 0xF0
    # The reason it works is that the set consists of exactly those bytes
    # whose first 4 bits are 1, and the next two are 0.  (The value of the
    # other 2 bits is immaterial in determining if a byte is in the set or
    # not.)  The mask masks out those 2 irrelevant bits, and the comparison
    # makes sure that the result matches all bytes which match those 6
    # material bits exactly.  In other words, the set of bytes contains
    # exactly those whose bottom two bit positions are either 0 or 1.  The
    # same principle applies to bit positions that are not necessarily
    # adjacent.  And it can be applied to bytes that differ in 1 through all 8
    # bit positions.  In order to be a candidate for this optimization, the
    # number of bytes in the set must be a power of 2.
    #
    # Consider a different example, the set 0x53, 0x54, 0x73, and 0x74.  That
    # requires 4 tests using either ranges or individual values, and even
    # though the number in the set is a power of 2, it doesn't qualify for the
    # mask optimization described above because the number of bits that are
    # different is too large for that.  However, the set can be expressed as
    # two branches with masks thusly:
    #   (c & 0xDF) == 0x53 || (c & 0xDF) == 0x54
    # a branch savings of 50%.  This is done by splitting the set into two
    # subsets each of which has 2 elements, and within each set the values
    # differ by 1 byte.
    #
    # This function attempts to find some way to save some branches using the
    # mask technique.  If not, it returns an empty list; if so, it
    # returns a list consisting of
    #   [ [compare1, mask1], [compare2, mask2], ...
    #     [compare_n, undef], [compare_m, undef], ...
    #   ]
    # The <mask> is undef in the above for those bytes that must be tested
    # for individually.
    #
    # This function does not attempt to find the optimal set.  To do so would
    # probably require testing all possible combinations, and keeping track of
    # the current best one.
    #
    # There are probably much better algorithms, but this is the one I (khw)
    # came up with.  We start with doing a bit-wise compare of every byte in
    # the set with every other byte.  The results are sorted into arrays of
    # all those that differ by the same bit positions.  These are stored in a
    # hash with the each key being the bits they differ in.  Here is the hash
    # for the 0x53, 0x54, 0x73, 0x74 set:
    # {
    #    4 => {
    #            "0,1,2,5" => [
    #                            83,
    #                            116,
    #                            84,
    #                            115
    #                        ]
    #        },
    #    3 => {
    #            "0,1,2" => [
    #                        83,
    #                        84,
    #                        115,
    #                        116
    #                        ]
    #        }
    #    1 => {
    #            5 => [
    #                    83,
    #                    115,
    #                    84,
    #                    116
    #                ]
    #        },
    # }
    #
    # The set consisting of values which differ in the 4 bit positions 0, 1,
    # 2, and 5 from some other value in the set consists of all 4 values.
    # Likewise all 4 values differ from some other value in the 3 bit
    # positions 0, 1, and 2; and all 4 values differ from some other value in
    # the single bit position 5.  The keys at the uppermost level in the above
    # hash, 1, 3, and 4, give the number of bit positions that each sub-key
    # below it has.  For example, the 4 key could have as its value an array
    # consisting of "0,1,2,5", "0,1,2,6", and "3,4,6,7", if the inputs were
    # such.  The best optimization will group the most values into a single
    # mask.  The most values will be the ones that differ in the most
    # positions, the ones with the largest value for the topmost key.  These
    # keys, are thus just for convenience of sorting by that number, and do
    # not have any bearing on the core of the algorithm.
    #
    # We start with an element from largest number of differing bits.  The
    # largest in this case is 4 bits, and there is only one situation in this
    # set which has 4 differing bits, "0,1,2,5".  We look for any subset of
    # this set which has 16 values that differ in these 4 bits.  There aren't
    # any, because there are only 4 values in the entire set.  We then look at
    # the next possible thing, which is 3 bits differing in positions "0,1,2".
    # We look for a subset that has 8 values that differ in these 3 bits.
    # Again there are none.  So we go to look for the next possible thing,
    # which is a subset of 2**1 values that differ only in bit position 5.  83
    # and 115 do, so we calculate a mask and base for those and remove them
    # from every set.  Since there is only the one set remaining, we remove
    # them from just this one.  We then look to see if there is another set of
    # 2 values that differ in bit position 5.  84 and 116 do, so we calculate
    # a mask and base for those and remove them from every set (again only
    # this set remains in this example).  The set is now empty, and there are
    # no more sets to look at, so we are done.

    if ($list_count == 256) {   # All 256 is trivially masked
        return (0, 0);
    }

    my %hash;

    # Generate bits-differing lists for each element compared against each
    # other element
    for my $i (0 .. $list_count - 2) {
        for my $j ($i + 1 .. $list_count - 1) {
            my @bits_that_differ = pop_count($list[$i] ^ $list[$j]);
            my $differ_count = @bits_that_differ;
            my $key = join ",", @bits_that_differ;
            push @{$hash{$differ_count}{$key}}, $list[$i] unless grep { $_ == $list[$i] } @{$hash{$differ_count}{$key}};
            push @{$hash{$differ_count}{$key}}, $list[$j];
        }
    }

    print STDERR __LINE__, ": calculate_mask() called:  List of values grouped by differing bits: ", Dumper \%hash if DEBUG;

    my @final_results;
    foreach my $count (reverse sort { $a <=> $b } keys %hash) {
        my $need = 2 ** $count;     # Need 8 values for 3 differing bits, etc
        foreach my $bits (sort keys $hash{$count}->%*) {

            print STDERR __LINE__, ": For $count bit(s) difference ($bits), need $need; have ", scalar @{$hash{$count}{$bits}}, "\n" if DEBUG;

            # Look only as long as there are at least as many elements in the
            # subset as are needed
            while ((my $cur_count = @{$hash{$count}{$bits}}) >= $need) {

                print STDERR __LINE__, ": Looking at bit positions ($bits): ", Dumper $hash{$count}{$bits} if DEBUG;

                # Start with the first element in it
                my $try_base = $hash{$count}{$bits}[0];
                my @subset = $try_base;

                # If it succeeds, we return a mask and a base to compare
                # against the masked value.  That base will be the AND of
                # every element in the subset.  Initialize to the one element
                # we have so far.
                my $compare = $try_base;

                # We are trying to find a subset of this that has <need>
                # elements that differ in the bit positions given by the
                # string $bits, which is comma separated.
                my @bits = split ",", $bits;

                TRY: # Look through the remainder of the list for other
                     # elements that differ only by these bit positions.

                for (my $i = 1; $i < $cur_count; $i++) {
                    my $try_this = $hash{$count}{$bits}[$i];
                    my @positions = pop_count($try_base ^ $try_this);

                    print STDERR __LINE__, ": $try_base vs $try_this: is (", join(',', @positions), ") a subset of ($bits)?" if DEBUG;;

                    foreach my $pos (@positions) {
                        unless (grep { $pos == $_ } @bits) {
                            print STDERR "  No\n" if DEBUG;
                            my $remaining = $cur_count - $i - 1;
                            if ($remaining && @subset + $remaining < $need) {
                                print STDERR __LINE__, ": Can stop trying $try_base, because even if all the remaining $remaining values work, they wouldn't add up to the needed $need when combined with the existing ", scalar @subset, " ones\n" if DEBUG;
                                last TRY;
                            }
                            next TRY;
                        }
                    }

                    print STDERR "  Yes\n" if DEBUG;
                    push @subset, $try_this;

                    # Add this to the mask base, in case it ultimately
                    # succeeds,
                    $compare &= $try_this;
                }

                print STDERR __LINE__, ": subset (", join(", ", @subset), ") has ", scalar @subset, " elements; needs $need\n" if DEBUG;

                if (@subset < $need) {
                    shift @{$hash{$count}{$bits}};
                    next;   # Try with next value
                }

                # Create the mask
                my $mask = 0;
                foreach my $position (@bits) {
                    $mask |= 1 << $position;
                }
                $mask = ~$mask & 0xFF;
                push @final_results, [$compare, $mask];

                printf STDERR "%d: Got it: compare=%d=0x%X; mask=%X\n", __LINE__, $compare, $compare, $mask if DEBUG;

                # These values are now spoken for.  Remove them from future
                # consideration
                foreach my $remove_count (sort keys %hash) {
                    foreach my $bits (sort keys %{$hash{$remove_count}}) {
                        foreach my $to_remove (@subset) {
                            @{$hash{$remove_count}{$bits}} = grep { $_ != $to_remove } @{$hash{$remove_count}{$bits}};
                        }
                    }
                }
            }
        }
    }

    # Any values that remain in the list are ones that have to be tested for
    # individually.
    my @individuals;
    foreach my $count (reverse sort { $a <=> $b } keys %hash) {
        foreach my $bits (sort keys $hash{$count}->%*) {
            foreach my $remaining (@{$hash{$count}{$bits}}) {

                # If we already know about this value, just ignore it.
                next if grep { $remaining == $_ } @individuals;

                # Otherwise it needs to be returned as something to match
                # individually
                push @final_results, [$remaining, undef];
                push @individuals, $remaining;
            }
        }
    }

    # Sort by increasing numeric value
    @final_results = sort { $a->[0] <=> $b->[0] } @final_results;

    print STDERR __LINE__, ": Final return: ", Dumper \@final_results if DEBUG;

    return @final_results;
}

# _cond_as_str
# turn a list of conditions into a text expression
# - merges ranges of conditions, and joins the result with ||
sub _cond_as_str {
    my ( $self, $op, $combine, $opts_ref )= @_;
    my $cond= $op->{vals};
    my $test= $op->{test};
    my $is_cp_ret = $opts_ref->{ret_type} eq "cp";
    return "( $test )" if !defined $cond;

    # rangify the list.
    my @ranges;
    my $Update= sub {
        # We skip this if there are optimizations that
        # we can apply (below) to the individual ranges
        if ( ($is_cp_ret || $combine) && @ranges && ref $ranges[-1]) {
            if ( $ranges[-1][0] == $ranges[-1][1] ) {
                $ranges[-1]= $ranges[-1][0];
            } elsif ( $ranges[-1][0] + 1 == $ranges[-1][1] ) {
                $ranges[-1]= $ranges[-1][0];
                push @ranges, $ranges[-1] + 1;
            }
        }
    };
    for my $condition ( @$cond ) {
        if ( !@ranges || $condition != $ranges[-1][1] + 1 ) {
            $Update->();
            push @ranges, [ $condition, $condition ];
        } else {
            $ranges[-1][1]++;
        }
    }
    $Update->();

    return $self->_combine( $test, @ranges )
      if $combine;

    if ($is_cp_ret) {
        @ranges= map {
            ref $_
            ? sprintf(
                "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
                @$_ )
            : sprintf( "$self->{val_fmt} == $test", $_ );
        } @ranges;

        return "( " . join( " || ", @ranges ) . " )";
    }

    # If the input set has certain characteristics, we can optimize tests
    # for it.  This doesn't apply if returning the code point, as we want
    # each element of the set individually.  The code above is for this
    # simpler case.

    return 1 if @$cond == 256;  # If all bytes match, is trivially true

    my @masks;
    if (@ranges > 1) {

        # See if the entire set shares optimizable characteristics, and if so,
        # return the optimization.  We delay checking for this on sets with
        # just a single range, as there may be better optimizations available
        # in that case.
        @masks = calculate_mask(@$cond);

        # Stringify the output of calculate_mask()
        if (@masks) {
            my @return;
            foreach my $mask_ref (@masks) {
                if (defined $mask_ref->[1]) {
                    push @return, sprintf "( ( $test & $self->{val_fmt} ) == $self->{val_fmt} )", $mask_ref->[1], $mask_ref->[0];
                }
                else {  # An undefined mask means to use the value as-is
                    push @return, sprintf "$test == $self->{val_fmt}", $mask_ref->[0];
                }
            }

            # The best possible case below for specifying this set of values via
            # ranges is 1 branch per range.  If our mask method yielded better
            # results, there is no sense trying something that is bound to be
            # worse.
            if (@return < @ranges) {
                return "( " . join( " || ", @return ) . " )";
            }

            @masks = @return;
        }
    }

    # Here, there was no entire-class optimization that was clearly better
    # than doing things by ranges.  Look at each range.
    my $range_count_extra = 0;
    for (my $i = 0; $i < @ranges; $i++) {
        if (! ref $ranges[$i]) {    # Trivial case: no range
            $ranges[$i] = sprintf "$self->{val_fmt} == $test", $ranges[$i];
        }
        elsif ($ranges[$i]->[0] == $ranges[$i]->[1]) {
            $ranges[$i] =           # Trivial case: single element range
                    sprintf "$self->{val_fmt} == $test", $ranges[$i]->[0];
        }
        elsif ($ranges[$i]->[0] == 0) {
            # If the range matches all 256 possible bytes, it is trivially
            # true.
            return 1 if $ranges[0]->[1] == 0xFF;    # @ranges must be 1 in
                                                    # this case
            $ranges[$i] = sprintf "( $test <= $self->{val_fmt} )",
                                                               $ranges[$i]->[1];
        }
        elsif ($ranges[$i]->[1] == 255) {

            # Similarly the max possible is 255, so can omit an upper bound
            # test if the calculated max is the max possible one.
            $ranges[$i] = sprintf "( $test >= $self->{val_fmt} )",
                                                                $ranges[0]->[0];
        }
        else {
            my $output = "";

            # Well-formed UTF-8 continuation bytes on ascii platforms must be
            # in the range 0x80 .. 0xBF.  If we know that the input is
            # well-formed (indicated by not trying to be 'safe'), we can omit
            # tests that verify that the input is within either of these
            # bounds.  (No legal UTF-8 character can begin with anything in
            # this range, so we don't have to worry about this being a
            # continuation byte or not.)
            if ($opts_ref->{charset} =~ /ascii/i
                && (! $opts_ref->{safe} && ! $opts_ref->{no_length_checks})
                && $opts_ref->{type} =~ / ^ (?: utf8 | high ) $ /xi)
            {
                my $lower_limit_is_80 = ($ranges[$i]->[0] == 0x80);
                my $upper_limit_is_BF = ($ranges[$i]->[1] == 0xBF);

                # If the range is the entire legal range, it matches any legal
                # byte, so we can omit both tests.  (This should happen only
                # if the number of ranges is 1.)
                if ($lower_limit_is_80 && $upper_limit_is_BF) {
                    return 1;
                }
                elsif ($lower_limit_is_80) { # Just use the upper limit test
                    $output = sprintf("( $test <= $self->{val_fmt} )",
                                        $ranges[$i]->[1]);
                }
                elsif ($upper_limit_is_BF) { # Just use the lower limit test
                    $output = sprintf("( $test >= $self->{val_fmt} )",
                                    $ranges[$i]->[0]);
                }
            }

            # If we didn't change to omit a test above, see if the number of
            # elements is a power of 2 (only a single bit in the
            # representation of its count will be set) and if so, it may be
            # that a mask/compare optimization is possible.
            if ($output eq ""
                && pop_count($ranges[$i]->[1] - $ranges[$i]->[0] + 1) == 1)
            {
                my @list;
                push @list, $_  for ($ranges[$i]->[0] .. $ranges[$i]->[1]);
                my @this_masks = calculate_mask(@list);

                # Use the mask if there is just one for the whole range.
                # Otherwise there is no savings over the two branches that can
                # define the range.
                if (@this_masks == 1 && defined $this_masks[0][1]) {
                    $output = sprintf "( $test & $self->{val_fmt} ) == $self->{val_fmt}", $this_masks[0][1], $this_masks[0][0];
                }
            }

            if ($output ne "") {  # Prefer any optimization
                $ranges[$i] = $output;
            }
            else {
                # No optimization happened.  We need a test that the code
                # point is within both bounds.  But, if the bounds are
                # adjacent code points, it is cleaner to say
                # 'first == test || second == test'
                # than it is to say
                # 'first <= test && test <= second'

                $range_count_extra++;   # This range requires 2 branches to
                                        # represent
                if ($ranges[$i]->[0] + 1 == $ranges[$i]->[1]) {
                    $ranges[$i] = "( "
                                .  join( " || ", ( map
                                    { sprintf "$self->{val_fmt} == $test", $_ }
                                    @{$ranges[$i]} ) )
                                . " )";
                }
                else {  # Full bounds checking
                    $ranges[$i] = sprintf("( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )", $ranges[$i]->[0], $ranges[$i]->[1]);
                }
            }
        }
    }

    # We have generated the list of bytes in two ways; one trying to use masks
    # to cut the number of branches down, and the other to look at individual
    # ranges (some of which could be cut down by using a mask for just it).
    # We return whichever method uses the fewest branches.
    return "( "
           . join( " || ", (@masks && @masks < @ranges + $range_count_extra)
                            ? @masks
                            : @ranges)
           . " )";
}

# _combine
# recursively turn a list of conditions into a fast break-out condition
# used by _cond_as_str() for 'cp' type macros.
sub _combine {
    my ( $self, $test, @cond )= @_;
    return if !@cond;
    my $item= shift @cond;
    my ( $cstr, $gtv );
    if ( ref $item ) {  # @item should be a 2-element array giving range start
                        # and end
        if ($item->[0] == 0) {  # UV's are never negative, so skip "0 <= "
                                # test which could generate a compiler warning
                                # that test is always true
            $cstr= sprintf( "$test <= $self->{val_fmt}", $item->[1] );
        }
        else {
            $cstr=
          sprintf( "( $self->{val_fmt} <= $test && $test <= $self->{val_fmt} )",
                   @$item );
        }
        $gtv= sprintf "$self->{val_fmt}", $item->[1];
    } else {
        $cstr= sprintf( "$self->{val_fmt} == $test", $item );
        $gtv= sprintf "$self->{val_fmt}", $item;
    }
    if ( @cond ) {
        my $combine= $self->_combine( $test, @cond );
        if (@cond >1) {
            return "( $cstr || ( $gtv < $test &&\n"
                   . $combine . " ) )";
        } else {
            return "( $cstr || $combine )";
        }
    } else {
        return $cstr;
    }
}

# _render()
# recursively convert an optree to text with reasonably neat formatting
sub _render {
    my ( $self, $op, $combine, $brace, $opts_ref, $def, $submacros )= @_;
    return 0 if ! defined $op;  # The set is empty
    if ( !ref $op ) {
        return $op;
    }
    my $cond= $self->_cond_as_str( $op, $combine, $opts_ref );
    #no warnings 'recursion';   # This would allow really really inefficient
                                # code to be generated.  See pod
    my $yes= $self->_render( $op->{yes}, $combine, 1, $opts_ref, $def, $submacros );
    return $yes if $cond eq '1';

    my $no= $self->_render( $op->{no},   $combine, 0, $opts_ref, $def, $submacros );
    return "( $cond )" if $yes eq '1' and $no eq '0';
    my ( $lb, $rb )= $brace ? ( "( ", " )" ) : ( "", "" );
    return "$lb$cond ? $yes : $no$rb"
      if !ref( $op->{yes} ) && !ref( $op->{no} );
    my $ind1= " " x 4;
    my $ind= "\n" . ( $ind1 x $op->{depth} );

    if ( ref $op->{yes} ) {
        $yes= $ind . $ind1 . $yes;
    } else {
        $yes= " " . $yes;
    }

    my $str= "$lb$cond ?$yes$ind: $no$rb";
    if (length $str > 6000) {
        push @$submacros, sprintf "#define $def\n( %s )", "_part" . (my $yes_idx= 0+@$submacros), $yes;
        push @$submacros, sprintf "#define $def\n( %s )", "_part" . (my $no_idx= 0+@$submacros), $no;
        return sprintf "%s%s ? $def : $def%s", $lb, $cond, "_part$yes_idx", "_part$no_idx", $rb;
    }
    return $str;
}

# $expr=render($op,$combine)
#
# convert an optree to text with reasonably neat formatting. If $combine
# is true then the condition is created using "fast breakouts" which
# produce uglier expressions that are more efficient for common case,
# longer lists such as that resulting from type 'cp' output.
# Currently only used for type 'cp' macros.
sub render {
    my ( $self, $op, $combine, $opts_ref, $def_fmt )= @_;
    
    my @submacros;
    my $macro= sprintf "#define $def_fmt\n( %s )", "", $self->_render( $op, $combine, 0, $opts_ref, $def_fmt, \@submacros );

    return join "\n\n", map { "/*** GENERATED CODE ***/\n" . __macro( __clean( $_ ) ) } @submacros, $macro;
}

# make_macro
# make a macro of a given type.
# calls into make_trie and (generic_|length_)optree as needed
# Opts are:
# type             : 'cp','cp_high', 'generic','high','low','latin1','utf8','LATIN1','UTF8'
# ret_type         : 'cp' or 'len'
# safe             : don't assume is well-formed UTF-8, so don't skip any range
#                    checks, and add length guards to macro
# no_length_checks : like safe, but don't add length guards.
#
# type defaults to 'generic', and ret_type to 'len' unless type is 'cp'
# in which case it defaults to 'cp' as well.
#
# It is illegal to do a type 'cp' macro on a pattern with multi-codepoint
# sequences in it, as the generated macro will accept only a single codepoint
# as an argument.
#
# It is also illegal to do a non-safe macro on a pattern with multi-codepoint
# sequences in it, as even if it is known to be well-formed, we need to not
# run off the end of the buffer when, say, the buffer ends with the first two
# characters, but three are looked at by the macro.
#
# returns the macro.


sub make_macro {
    my $self= shift;
    my %opts= @_;
    my $type= $opts{type} || 'generic';
    if ($self->{has_multi}) {
        if ($type =~ /^cp/) {
            die "Can't do a 'cp' on multi-codepoint character class '$self->{op}'"
        }
        elsif (! $opts{safe}) {
            die "'safe' is required on multi-codepoint character class '$self->{op}'"
        }
    }
    my $ret_type= $opts{ret_type} || ( $opts{type} =~ /^cp/ ? 'cp' : 'len' );
    my $method;
    if ( $opts{safe} ) {
        $method= 'length_optree';
    } elsif ( $type =~ /generic/ ) {
        $method= 'generic_optree';
    } else {
        $method= 'optree';
    }
    my @args= $type =~ /^cp/ ? 'cp' : 's';
    push @args, "e" if $opts{safe};
    push @args, "is_utf8" if $type =~ /generic/;
    push @args, "len" if $ret_type eq 'both';
    my $pfx= $ret_type eq 'both'    ? 'what_len_' : 
             $ret_type eq 'cp'      ? 'what_'     : 'is_';
    my $ext= $type     =~ /generic/ ? ''          : '_' . lc( $type );
    $ext .= '_non_low' if $type eq 'generic_non_low';
    $ext .= "_safe" if $opts{safe};
    $ext .= "_no_length_checks" if $opts{no_length_checks};
    my $argstr= join ",", @args;
    my $def_fmt="$pfx$self->{op}$ext%s($argstr)";
    my $optree= $self->$method( %opts, type => $type, ret_type => $ret_type );
    return $self->render( $optree, ($type =~ /^cp/) ? 1 : 0, \%opts, $def_fmt );
}

# if we aren't being used as a module (highly likely) then process
# the __DATA__ below and produce macros in regcharclass.h
# if an argument is provided to the script then it is assumed to
# be the path of the file to output to, if the arg is '-' outputs
# to STDOUT.
if ( !caller ) {
    $|++;
    my $path= shift @ARGV || "regcharclass.h";
    my $out_fh;
    if ( $path eq '-' ) {
        $out_fh= \*STDOUT;
    } else {
	$out_fh = open_new( $path );
    }
    print $out_fh read_only_top( lang => 'C', by => $0,
				 file => 'regcharclass.h', style => '*',
				 copyright => [2007, 2011],
                                 final => <<EOF,
WARNING: These macros are for internal Perl core use only, and may be
changed or removed without notice.
EOF
    );
    print $out_fh "\n#ifndef H_REGCHARCLASS   /* Guard against nested #includes */\n#define H_REGCHARCLASS 1\n";

    my ( $op, $title, @txt, @types, %mods );
    my $doit= sub ($) {
        return unless $op;

        my $charset = shift;

        # Skip if to compile on a different platform.
        return if delete $mods{only_ascii_platform} && $charset !~ /ascii/i;
        return if delete $mods{only_ebcdic_platform} && $charset !~ /ebcdic/i;

        print $out_fh "/*\n\t$op: $title\n\n";
        print $out_fh join "\n", ( map { "\t$_" } @txt ), "*/", "";
        my $obj= __PACKAGE__->new( op => $op, title => $title, txt => \@txt, charset => $charset);

        #die Dumper(\@types,\%mods);

        my @mods;
        push @mods, 'safe' if delete $mods{safe};
        push @mods, 'no_length_checks' if delete $mods{no_length_checks};
        unshift @mods, 'fast' if delete $mods{fast} || ! @mods; # Default to 'fast'
                                                                # do this one
                                                                # first, as
                                                                # traditional
        if (%mods) {
            die "Unknown modifiers: ", join ", ", map { "'$_'" } sort keys %mods;
        }

        foreach my $type_spec ( @types ) {
            my ( $type, $ret )= split /-/, $type_spec;
            $ret ||= 'len';
            foreach my $mod ( @mods ) {

                # 'safe' is irrelevant with code point macros, so skip if
                # there is also a 'fast', but don't skip if this is the only
                # way a cp macro will get generated.  Below we convert 'safe'
                # to 'fast' in this instance
                next if $type =~ /^cp/
                        && ($mod eq 'safe' || $mod eq 'no_length_checks')
                        && grep { 'fast' =~ $_ } @mods;
                delete $mods{$mod};
                my $macro= $obj->make_macro(
                    type     => $type,
                    ret_type => $ret,
                    safe     => $mod eq 'safe' && $type !~ /^cp/,
                    charset  => $charset,
                    no_length_checks => $mod eq 'no_length_checks' && $type !~ /^cp/,
                );
                print $out_fh $macro, "\n";
            }
        }
    };

    my @data = <DATA>;
    foreach my $charset (get_supported_code_pages()) {
        my $first_time = 1;
        undef $op;
        undef $title;
        undef @txt;
        undef @types;
        undef %mods;
        print $out_fh "\n", get_conditional_compile_line_start($charset);
        my @data_copy = @data;
        for (@data_copy) {
            s/^ \s* (?: \# .* ) ? $ //x;    # squeeze out comment and blanks
            next unless /\S/;
            chomp;
            if ( /^[A-Z]/ ) {
                $doit->($charset) unless $first_time;  # This starts a new
                                                       # definition; do the
                                                       # previous one
                $first_time = 0;
                ( $op, $title )= split /\s*:\s*/, $_, 2;
                @txt= ();
            } elsif ( s/^=>// ) {
                my ( $type, $modifier )= split /:/, $_;
                @types= split ' ', $type;
                undef %mods;
                map { $mods{$_} = 1 } split ' ',  $modifier;
            } else {
                push @txt, "$_";
            }
        }
        $doit->($charset);
        print $out_fh get_conditional_compile_line_end();
    }

    print $out_fh "\n#endif /* H_REGCHARCLASS */\n";

    if($path eq '-') {
	print $out_fh "/* ex: set ro: */\n";
    } else {
        # Some of the sources for these macros come from Unicode tables
        my $sources_list = "lib/unicore/mktables.lst";
        my @sources = ($0, qw(lib/unicore/mktables
                              lib/Unicode/UCD.pm
                              regen/regcharclass_multi_char_folds.pl
                              regen/charset_translations.pl
                             ));
        {
            # Depend on mktables’ own sources.  It’s a shorter list of files than
            # those that Unicode::UCD uses.
            if (! open my $mktables_list, $sources_list) {

                # This should force a rebuild once $sources_list exists
                push @sources, $sources_list;
            }
            else {
                while(<$mktables_list>) {
                    last if /===/;
                    chomp;
                    push @sources, "lib/unicore/$_" if /^[^#]/;
                }
            }
        }
        read_only_bottom_close_and_rename($out_fh, \@sources)
    }
}

# The form of the input is a series of definitions to make macros for.
# The first line gives the base name of the macro, followed by a colon, and
# then text to be used in comments associated with the macro that are its
# title or description.  In all cases the first (perhaps only) parameter to
# the macro is a pointer to the first byte of the code point it is to test to
# see if it is in the class determined by the macro.  In the case of non-UTF8,
# the code point consists only of a single byte.
#
# The second line must begin with a '=>' and be followed by the types of
# macro(s) to be generated; these are specified below.  A colon follows the
# types, followed by the modifiers, also specified below.  At least one
# modifier is required.
#
# The subsequent lines give what code points go into the class defined by the
# macro.  Multiple characters may be specified via a string like "\x0D\x0A",
# enclosed in quotes.  Otherwise the lines consist of one of:
#   1)  a single Unicode code point, prefaced by 0x
#   2)  a single range of Unicode code points separated by a minus (and
#       optional space)
#   3)  a single Unicode property specified in the standard Perl form
#       "\p{...}"
#   4)  a line like 'do path'.  This will do a 'do' on the file given by
#       'path'.  It is assumed that this does nothing but load subroutines
#       (See item 5 below).  The reason 'require path' is not used instead is
#       because 'do' doesn't assume that path is in @INC.
#   5)  a subroutine call
#           &pkg::foo(arg1, ...)
#       where pkg::foo was loaded by a 'do' line (item 4).  The subroutine
#       returns an array of entries of forms like items 1-3 above.  This
#       allows more complex inputs than achievable from the other input types.
#
# A blank line or one whose first non-blank character is '#' is a comment.
# The definition of the macro is terminated by a line unlike those described.
#
# Valid types:
#   low         generate a macro whose name is 'is_BASE_low' and defines a
#               class that includes only ASCII-range chars.  (BASE is the
#               input macro base name.)
#   latin1      generate a macro whose name is 'is_BASE_latin1' and defines a
#               class that includes only upper-Latin1-range chars.  It is not
#               designed to take a UTF-8 input parameter.
#   high        generate a macro whose name is 'is_BASE_high' and defines a
#               class that includes all relevant code points that are above
#               the Latin1 range.  This is for very specialized uses only.
#               It is designed to take only an input UTF-8 parameter.
#   utf8        generate a macro whose name is 'is_BASE_utf8' and defines a
#               class that includes all relevant characters that aren't ASCII.
#               It is designed to take only an input UTF-8 parameter.
#   LATIN1      generate a macro whose name is 'is_BASE_latin1' and defines a
#               class that includes both ASCII and upper-Latin1-range chars.
#               It is not designed to take a UTF-8 input parameter.
#   UTF8        generate a macro whose name is 'is_BASE_utf8' and defines a
#               class that can include any code point, adding the 'low' ones
#               to what 'utf8' works on.  It is designed to take only an input
#               UTF-8 parameter.
#   generic     generate a macro whose name is 'is_BASE".  It has a 2nd,
#               boolean, parameter which indicates if the first one points to
#               a UTF-8 string or not.  Thus it works in all circumstances.
#   generic_non_low generate a macro whose name is 'is_BASE_non_low".  It has
#               a 2nd, boolean, parameter which indicates if the first one
#               points to a UTF-8 string or not.  It excludes any ASCII-range
#               matches, but otherwise it works in all circumstances.
#   cp          generate a macro whose name is 'is_BASE_cp' and defines a
#               class that returns true if the UV parameter is a member of the
#               class; false if not.
#   cp_high     like cp, but it is assumed that it is known that the UV
#               parameter is above Latin1.  The name of the generated macro is
#               'is_BASE_cp_high'.  This is different from high-cp, derived
#               below.
# A macro of the given type is generated for each type listed in the input.
# The default return value is the number of octets read to generate the match.
# Append "-cp" to the type to have it instead return the matched codepoint.
#               The macro name is changed to 'what_BASE...'.  See pod for
#               caveats
# Appending '-both" instead adds an extra parameter to the end of the argument
#               list, which is a pointer as to where to store the number of
#               bytes matched, while also returning the code point.  The macro
#               name is changed to 'what_len_BASE...'.  See pod for caveats
#
# Valid modifiers:
#   safe        The input string is not necessarily valid UTF-8.  In
#               particular an extra parameter (always the 2nd) to the macro is
#               required, which points to one beyond the end of the string.
#               The macro will make sure not to read off the end of the
#               string.  In the case of non-UTF8, it makes sure that the
#               string has at least one byte in it.  The macro name has
#               '_safe' appended to it.
#   no_length_checks  The input string is not necessarily valid UTF-8, but it
#               is to be assumed that the length has already been checked and
#               found to be valid
#   fast        The input string is valid UTF-8.  No bounds checking is done,
#               and the macro can make assumptions that lead to faster
#               execution.
#   only_ascii_platform   Skip this definition if the character set is for
#               a non-ASCII platform.
#   only_ebcdic_platform  Skip this definition if the character set is for
#               a non-EBCDIC platform.
# No modifier need be specified; fast is assumed for this case.  If both
# 'fast', and 'safe' are specified, two macros will be created for each
# 'type'.
#
# If run on a non-ASCII platform will automatically convert the Unicode input
# to native.  The documentation above is slightly wrong in this case.  'low'
# actually refers to code points whose UTF-8 representation is the same as the
# non-UTF-8 version (invariants); and 'latin1' refers to all the rest of the
# code points less than 256.

1; # in the unlikely case we are being used as a module

__DATA__
# This is no longer used, but retained in case it is needed some day.
# TRICKYFOLD: Problematic fold case letters.  When adding to this list, also should add them to regcomp.c and fold_grind.t
# => generic cp generic-cp generic-both :fast safe
# 0x00DF	# LATIN SMALL LETTER SHARP S
# 0x0390	# GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
# 0x03B0	# GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
# 0x1E9E  # LATIN CAPITAL LETTER SHARP S, because maps to same as 00DF
# 0x1FD3  # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA; maps same as 0390
# 0x1FE3  # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA; maps same as 03B0

LNBREAK: Line Break: \R
=> generic UTF8 LATIN1 : safe
"\x0D\x0A"      # CRLF - Network (Windows) line ending
\p{VertSpace}

HORIZWS: Horizontal Whitespace: \h \H
=> high cp_high : fast
\p{HorizSpace}

VERTWS: Vertical Whitespace: \v \V
=> high cp_high : fast
\p{VertSpace}

XDIGIT: Hexadecimal digits
=> high cp_high : fast
\p{XDigit}

XPERLSPACE: \p{XPerlSpace}
=> high cp_high : fast
\p{XPerlSpace}

REPLACEMENT: Unicode REPLACEMENT CHARACTER
=> UTF8 :safe
0xFFFD

NONCHAR: Non character code points
=> UTF8 :fast
\p{_Perl_Nchar}

SURROGATE: Surrogate characters
=> UTF8 :fast
\p{_Perl_Surrogate}

# This program was run with this enabled, and the results copied to utf8.h;
# then this was commented out because it takes so long to figure out these 2
# million code points.  The results would not change unless utf8.h decides it
# wants a maximum other than 4 bytes, or this program creates better
# optimizations.  Trying with 5 bytes used too much memory to calculate.
#
# We don't generate code for invariants here because the EBCDIC form is too
# complicated and would slow things down; instead the user should test for
# invariants first.
#
# NOTE: The number of bytes generated here must match the value in
# IS_UTF8_CHAR_FAST in utf8.h
#
#UTF8_CHAR: Matches legal UTF-8 encoded characters from 2 through 4 bytes
#=> UTF8 :no_length_checks only_ascii_platform
#0x80 - 0x1FFFFF

# This hasn't been commented out, but the number of bytes it works on has been
# cut down to 3, so it doesn't cover the full legal Unicode range.  Making it
# 5 bytes would cover beyond the full range, but takes quite a bit of time and
# memory to calculate.  The generated table varies depending on the EBCDIC
# code page.

# NOTE: The number of bytes generated here must match the value in
# IS_UTF8_CHAR_FAST in utf8.h
#
UTF8_CHAR: Matches legal UTF-EBCDIC encoded characters from 2 through 3 bytes
=> UTF8 :no_length_checks only_ebcdic_platform
0xA0 - 0x3FFF

QUOTEMETA: Meta-characters that \Q should quote
=> high :fast
\p{_Perl_Quotemeta}

MULTI_CHAR_FOLD: multi-char strings that are folded to by a single character
=> UTF8 :safe

# 1 => All folds
&regcharclass_multi_char_folds::multi_char_folds(1)

MULTI_CHAR_FOLD: multi-char strings that are folded to by a single character
=> LATIN1 : safe

&regcharclass_multi_char_folds::multi_char_folds(0)
# 0 => Latin1-only

FOLDS_TO_MULTI: characters that fold to multi-char strings
=> UTF8 :fast
\p{_Perl_Folds_To_Multi_Char}

PROBLEMATIC_LOCALE_FOLD : characters whose fold is problematic under locale
=> UTF8 cp :fast
\p{_Perl_Problematic_Locale_Folds}

PROBLEMATIC_LOCALE_FOLDEDS_START : The first folded character of folds which are problematic under locale
=> UTF8 cp :fast
\p{_Perl_Problematic_Locale_Foldeds_Start}

PATWS: pattern white space
=> generic cp : safe
\p{_Perl_PatWS}