chiark - git - mdw - dpkg/blob - dselect/mkcurkeys.pl

   1 #!/usr/bin/perl
   2 #
   3 # dselect - Debian package maintenance user interface
   4 # mkcurkeys.pl - generate strings mapping key names to ncurses numbers
   5 #
   6 # Copyright © 1995 Ian Jackson <ijackson@chiark.greenend.org.uk>
   7 #
   8 # This is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  20
  21 use strict;
  22 use warnings;
  23
  24 use Scalar::Util qw(looks_like_number);
  25
  26 die 'usage: mkcurkeys.pl <filename> <curses.h>' if @ARGV != 2;
  27
  28 my (%over, %base, %name);
  29
  30 open(my $override_fh, '<', $ARGV[0]) or die $!;
  31 while (<$override_fh>) {
  32     chomp;
  33     /^#/ && next; # skip comments
  34     /\S/ || next; # ignore blank lines
  35     if (/^(\w+)\s+(\S.*\S)\s*$/) {
  36         $over{$1} = $2;
  37         $base{$1} = '';
  38     } else {
  39         die "cannot parse line:\n$_\n";
  40     }
  41 }
  42 close($override_fh);
  43
  44 my $let = 'A';
  45 for my $i (1 .. 26) {
  46     $name{$i}= "^$let";
  47     $base{$i}= '';
  48     $let++;
  49 }
  50
  51 my ($k, $v);
  52
  53 open(my $header_fh, '<', $ARGV[1]) or die $!;
  54 while (<$header_fh>) {
  55     s/\s+$//;
  56     m/#define KEY_(\w+)\s+\d+\s+/p || next;
  57     my $rhs = ${^POSTMATCH};
  58     $k= "KEY_$1";
  59     $base{$k} = capit($1);
  60     $rhs =~ s/(\w)[\(\)]/$1/g;
  61     $rhs =~ s/\w+ \((\w+)\)/$1/;
  62     next unless $rhs =~ m{^/\* (\w[\w ]+\w) \*/$};
  63     my $name = $1;
  64     $name =~ s/ key$//;
  65     if ($name =~ s/^shifted /shift /) {
  66         next if $name =~ m/ .* .* /;
  67     } else {
  68         next if $name =~ m/ .* /;
  69     }
  70     $name{$k} = capit($name);
  71 }
  72 close($header_fh);
  73
  74 printf(<<'END') or die $!;
  75 /*
  76  * WARNING - THIS FILE IS GENERATED AUTOMATICALLY - DO NOT EDIT
  77  * It is generated by mkcurkeys.pl from <curses.h>
  78  * and keyoverride.  If you want to override things try adding
  79  * them to keyoverride.
  80  */
  81
  82 END
  83
  84 my ($comma);
  85
  86 for my $i (33 .. 126) {
  87     $k= $i;
  88     $v = pack('C', $i);
  89     if ($v eq ',') { $comma=$k; next; }
  90     p($k, $v);
  91 }
  92
  93 ## no critic (BuiltinFunctions::ProhibitReverseSortBlock)
  94 for my $k (sort {
  95     looks_like_number($a) ?
  96         looks_like_number($b) ? $a <=> $b : -1
  97             : looks_like_number($b) ? 1 :
  98                 $a cmp $b
  99                 } keys %base) {
 100     ## use critic
 101     $v= $base{$k};
 102     $v= $name{$k} if defined($name{$k});
 103     $v= $over{$k} if defined($over{$k});
 104     next if $v eq '[elide]';
 105     p($k, $v);
 106 }
 107
 108 for my $i (1 .. 63) {
 109     p("KEY_F($i)", "F$i");
 110 }
 111
 112 p($comma, ',');
 113
 114 print(<<'END') or die $!;
 115   { -1,              nullptr              }
 116 END
 117
 118 close(STDOUT) or die $!;
 119 exit(0);
 120
 121 sub capit {
 122     my $str = shift;
 123     my $o = '';
 124
 125     $str =~ y/A-Z/a-z/;
 126     $str = " $str";
 127     while ($str =~ m/ (\w)/p) {
 128         $o .= ${^PREMATCH} . ' ';
 129         $str = $1;
 130         $str =~ y/a-z/A-Z/;
 131         $o .= $str;
 132         $str = ${^POSTMATCH};
 133     }
 134     $str = $o . $str;
 135     $str =~ s/^ //;
 136
 137     return $str;
 138 }
 139
 140 sub p {
 141     my ($k, $v) = @_;
 142
 143     $v =~ s/(["\\])/\\$1/g;
 144     printf("  { %-15s \"%-20s },\n", $k . ',', $v . '"') or die $!;
 145 }