"Fossies" - the Fresh Open Source Software Archive

Member "s-nail-14.9.10/make-tcap-map.pl" (25 Mar 2018, 3757 Bytes) of package /linux/misc/s-nail-14.9.10.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "make-tcap-map.pl" see the Fossies "Dox" file reference documentation.

    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