Rudely fix the RFC 5322 dot-atom, the "Dr. Problem" (Dr. Werner Fink)
[s-mailx.git] / mk-tcap-map.pl
blobb998162234fa053fbf9da6a9fb25daaa5e8a87fb
1 #!/usr/bin/env perl
2 require 5.008_001;
3 use utf8;
4 #@ Parse 'enum n_termcap_{cmd,query}' from nail.h and create tcaps.h.
5 #@ And see termcap.c.
6 # Public Domain
8 my $OUT = 'tcaps.h';
10 # Generate a more verbose output. Not for shipout versions.
11 my $VERB = 1;
13 ## -- >8 -- 8< -- ##
15 use diagnostics -verbose;
16 use strict;
17 use warnings;
19 my ($S, $CAPS_LEN, $BIND_START, @CAPS_NAMES, @ENTS) =
20 (($VERB ? ' ' : ''), 0, -1);
22 sub main_fun{
23 if(@ARGV) {$VERB = 0; $S = ''}
25 parse_nail_h();
27 dump_data();
28 exit 0
31 sub parse_nail_h{
32 die "nail.h: open: $^E" unless open F, '<', 'nail.h';
33 my ($init) = (0);
34 while(<F>){
35 chomp;
37 # Only want the enum okeys content
38 if(/^enum n_termcap_cmd/){
39 $init = 1;
40 next
42 if(!$init && /^enum n_termcap_query/){
43 $init = 2;
44 next
46 if(/^\};/){
47 if($init == 2){
48 $init = 3;
49 last
51 $init = 0;
52 next
54 $init || next;
56 # Ignore empty and comment lines
57 /^$/ && next;
58 if(/^\s*\/\*/){
59 # However, one special directive we know
60 $BIND_START = @CAPS_NAMES + 1 if /--mk-tcap-map--/;
61 next
64 # We need to preserve preprocessor conditionals
65 if(/^\s*#/){
66 push @ENTS, [$_];
67 next
70 # An entry is a constant followed by a specially crafted comment;
71 # ignore anything else
72 /^\s*(\w+),\s*
73 \/\*\s*(\w+|-)\s*\/\s*([^,\s]+|-),
74 \s*(\w+)\s*
75 (?:,\s*(\w+)\s*)?
76 (?:\||\*\/)
77 /x;
78 next unless $1 && $2 && $3 && $4;
79 die "Unsupported terminal capability type: $4"
80 unless($4 eq 'BOOL' || $4 eq 'NUMERIC' || $4 eq 'STRING');
82 my $e = 'n_TERMCAP_CAPTYPE_' . $4;
83 $e = $e . '|a_TERMCAP_F_QUERY' if $init == 2;
84 $e = $e . '|a_TERMCAP_F_ARG_' . $5 if $5;
85 push @ENTS, [$1, $e, $CAPS_LEN];
86 # termcap(5) names are always two chars, place them first, don't add NUL
87 my ($ti, $tc) = ($2, $3);
88 $tc = '' if $tc eq '-';
89 $ti = '' if $ti eq '-';
90 my $l = 2 +0 + length($ti) +1;
91 push @CAPS_NAMES, [$1, $CAPS_LEN, $l, $tc, $ti];
92 $CAPS_LEN += $l;
94 die 'nail.h does not have the expected content' unless $init == 3;
95 close F
98 sub dump_data{
99 die "$OUT: open: $^E" unless open F, '>', $OUT;
100 print F "/*@ $OUT, generated by $0 on ", scalar gmtime(), ".\n",
101 " *@ See termcap.c for more */\n\n";
103 print F 'static char const a_termcap_namedat[] = {', "\n";
104 foreach my $np (@CAPS_NAMES){
105 sub _exp{
106 if(length $_[0]){
107 $_[0] = '\'' . join('\',\'', split(//, $_[0])) . '\',';
108 }elsif($_[1] > 0){
109 $_[0] = '\'\0\',' x $_[1];
113 if($BIND_START > 0){
114 print F '#ifdef HAVE_KEY_BINDINGS', "\n" if(--$BIND_START == 0)
116 my ($tcn, $tin) = (_exp(scalar $np->[3], 2), _exp(scalar $np->[4], 0));
117 if($VERB){
118 print F "${S}/* [$np->[1]]+$np->[2], $np->[0] */ $tcn $tin'\\0',\n"
119 }else{
120 print F "${S}$tcn $tin'\\0',\n"
123 print F '#endif /* HAVE_KEY_BINDINGS */', "\n" if($BIND_START == 0);
124 print F '};', "\n\n";
126 print F 'static struct a_termcap_control const a_termcap_control[] = {',
127 "\n";
128 my $i = 0;
129 foreach my $ent (@ENTS){
130 if($#$ent == 0){
131 print F $ent->[0], "\n"
132 }else{
133 if($VERB){
134 print F ${S}, '{/* ', $i, '. ', $ent->[0], ' */ ', $ent->[1], ', ',
135 $ent->[2], "},\n"
136 }else{
137 print F "{$ent->[1], $ent->[2]},\n"
139 ++$i
142 print F '};', "\n";
144 die "$OUT: close: $^E" unless close F
147 {package main; main_fun()}
149 # s-it-mode