make-tcap-map.pl

   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 gen-tcaps.h.
   5 #@ And see termcap.c.
   6 # Public Domain
   7
   8 my $OUT = 'gen-tcaps.h';
   9
  10 # Generate a more verbose output.  Not for shipout versions.
  11 my $VERB = 1;
  12
  13 ##  --  >8  --  8<  --  ##
  14
  15 use diagnostics -verbose;
  16 use strict;
  17 use warnings;
  18
  19 my ($S, $CAPS_LEN, $BIND_START, @CAPS_NAMES, @ENTS) =
  20       (($VERB ? '   ' : ''), 0, -1);
  21
  22 sub main_fun{
  23    if(@ARGV) {$VERB = 0; $S = ''}
  24
  25    parse_nail_h();
  26
  27    dump_data();
  28    exit 0
  29 }
  30
  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;
  36
  37       # Only want the enum okeys content
  38       if(/^enum n_termcap_cmd/){
  39          $init = 1;
  40          next
  41       }
  42       if(!$init && /^enum n_termcap_query/){
  43          $init = 2;
  44          next
  45       }
  46       if(/^\};/){
  47          if($init == 2){
  48             $init = 3;
  49             last
  50          }
  51          $init = 0;
  52          next
  53       }
  54       $init || next;
  55
  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 /--make-tcap-map--/;
  61          next
  62       }
  63
  64       # We need to preserve preprocessor conditionals
  65       if(/^\s*#/){
  66          push @ENTS, [$_];
  67          next
  68       }
  69
  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');
  81
  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;
  93    }
  94    die 'nail.h does not have the expected content' unless $init == 3;
  95    close F
  96 }
  97
  98 sub dump_data{
  99    die "$OUT: open: $^E" unless open F, '>', $OUT;
 100    print F "/*@ $OUT, generated by $0.\n",
 101       " *@ See termcap.c for more */\n\n";
 102
 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];
 110          }
 111       }
 112
 113       if($BIND_START > 0){
 114          print F '#ifdef HAVE_KEY_BINDINGS', "\n" if(--$BIND_START == 0)
 115       }
 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"
 121       }
 122    }
 123    print F '#endif /* HAVE_KEY_BINDINGS */', "\n" if($BIND_START == 0);
 124    print F '};', "\n\n";
 125
 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"
 138          }
 139          ++$i
 140       }
 141    }
 142    print F '};', "\n";
 143
 144    die "$OUT: close: $^E" unless close F
 145 }
 146
 147 {package main; main_fun()}
 148
 149 # s-it-mode