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 open(my $header_fh, '<', $ARGV[1]) or die $!;
  52 while (<$header_fh>) {
  53     s/\s+$//;
  54     m/#define KEY_(\w+)\s+\d+\s+/p || next;
  55     my $rhs = ${^POSTMATCH};
  56     my $k = "KEY_$1";
  57     $base{$k} = capit($1);
  58     $rhs =~ s/(\w)[\(\)]/$1/g;
  59     $rhs =~ s/\w+ \((\w+)\)/$1/;
  60     next unless $rhs =~ m{^/\* (\w[\w ]+\w) \*/$};
  61     my $name = $1;
  62     $name =~ s/ key$//;
  63     if ($name =~ s/^shifted /shift /) {
  64         next if $name =~ m/ .* .* /;
  65     } else {
  66         next if $name =~ m/ .* /;
  67     }
  68     $name{$k} = capit($name);
  69 }
  70 close($header_fh);
  71
  72 printf(<<'END') or die $!;
  73 /*
  74  * WARNING - THIS FILE IS GENERATED AUTOMATICALLY - DO NOT EDIT
  75  * It is generated by mkcurkeys.pl from <curses.h>
  76  * and keyoverride.  If you want to override things try adding
  77  * them to keyoverride.
  78  */
  79
  80 END
  81
  82 my ($comma);
  83
  84 for my $i (33 .. 126) {
  85     my $k = $i;
  86     my $v = pack('C', $i);
  87     if ($v eq ',') { $comma = $k; next; }
  88     p($k, $v);
  89 }
  90
  91 ## no critic (BuiltinFunctions::ProhibitReverseSortBlock)
  92 for my $k (sort {
  93     looks_like_number($a) ?
  94         looks_like_number($b) ? $a <=> $b : -1
  95             : looks_like_number($b) ? 1 :
  96                 $a cmp $b
  97                 } keys %base) {
  98     ## use critic
  99     my $v;
 100     $v = $base{$k};
 101     $v = $name{$k} if defined($name{$k});
 102     $v = $over{$k} if defined($over{$k});
 103     next if $v eq '[elide]';
 104     p($k, $v);
 105 }
 106
 107 for my $i (1 .. 63) {
 108     p("KEY_F($i)", "F$i");
 109 }
 110
 111 p($comma, ',');
 112
 113 print(<<'END') or die $!;
 114   { -1,              nullptr              }
 115 END
 116
 117 close(STDOUT) or die $!;
 118 exit(0);
 119
 120 sub capit {
 121     my $str = shift;
 122     my $o = '';
 123
 124     $str =~ y/A-Z/a-z/;
 125     $str = " $str";
 126     while ($str =~ m/ (\w)/p) {
 127         $o .= ${^PREMATCH} . ' ';
 128         $str = $1;
 129         $str =~ y/a-z/A-Z/;
 130         $o .= $str;
 131         $str = ${^POSTMATCH};
 132     }
 133     $str = $o . $str;
 134     $str =~ s/^ //;
 135
 136     return $str;
 137 }
 138
 139 sub p {
 140     my ($k, $v) = @_;
 141
 142     $v =~ s/(["\\])/\\$1/g;
 143     printf("  { %-15s \"%-20s },\n", $k . ',', $v . '"') or die $!;
 144 }