awful debugging hacking

[dpkg] / dselect / mkcurkeys.pl

#!/usr/bin/perl
#
# dselect - Debian package maintenance user interface
# mkcurkeys.pl - generate strings mapping key names to ncurses numbers
#
# Copyright © 1995 Ian Jackson <ijackson@chiark.greenend.org.uk>
#
# This is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

use strict;
use warnings;

use Scalar::Util qw(looks_like_number);

die 'usage: mkcurkeys.pl <filename> <curses.h>' if @ARGV != 2;

my (%over, %base, %name);

open(my $override_fh, '<', $ARGV[0]) or die $!;
while (<$override_fh>) {
    chomp;
    /^#/ && next; # skip comments
    /\S/ || next; # ignore blank lines
    if (/^(\w+)\s+(\S.*\S)\s*$/) {
        $over{$1} = $2;
        $base{$1} = '';
    } else {
        die "cannot parse line:\n$_\n";
    }
}
close($override_fh);

my $let = 'A';
for my $i (1 .. 26) {
    $name{$i}= "^$let";
    $base{$i}= '';
    $let++;
}

my ($k, $v);

open(my $header_fh, '<', $ARGV[1]) or die $!;
while (<$header_fh>) {
    s/\s+$//;
    m/#define KEY_(\w+)\s+\d+\s+/p || next;
    my $rhs = ${^POSTMATCH};
    $k= "KEY_$1";
    $base{$k} = capit($1);
    $rhs =~ s/(\w)[\(\)]/$1/g;
    $rhs =~ s/\w+ \((\w+)\)/$1/;
    next unless $rhs =~ m{^/\* (\w[\w ]+\w) \*/$};
    my $name = $1;
    $name =~ s/ key$//;
    if ($name =~ s/^shifted /shift /) {
        next if $name =~ m/ .* .* /;
    } else {
        next if $name =~ m/ .* /;
    }
    $name{$k} = capit($name);
}
close($header_fh);

printf(<<'END') or die $!;
/*
 * WARNING - THIS FILE IS GENERATED AUTOMATICALLY - DO NOT EDIT
 * It is generated by mkcurkeys.pl from <curses.h>
 * and keyoverride.  If you want to override things try adding
 * them to keyoverride.
 */

END

my ($comma);

for my $i (33 .. 126) {
    $k= $i;
    $v = pack('C', $i);
    if ($v eq ',') { $comma=$k; next; }
    p($k, $v);
}

## no critic (BuiltinFunctions::ProhibitReverseSortBlock)
for my $k (sort {
    looks_like_number($a) ?
        looks_like_number($b) ? $a <=> $b : -1
            : looks_like_number($b) ? 1 :
                $a cmp $b
                } keys %base) {
    ## use critic
    $v= $base{$k};
    $v= $name{$k} if defined($name{$k});
    $v= $over{$k} if defined($over{$k});
    next if $v eq '[elide]';
    p($k, $v);
}

for my $i (1 .. 63) {
    p("KEY_F($i)", "F$i");
}

p($comma, ',');

print(<<'END') or die $!;
  { -1,              nullptr              }
END

close(STDOUT) or die $!;
exit(0);

sub capit {
    my $str = shift;
    my $o = '';

    $str =~ y/A-Z/a-z/;
    $str = " $str";
    while ($str =~ m/ (\w)/p) {
        $o .= ${^PREMATCH} . ' ';
        $str = $1;
        $str =~ y/a-z/A-Z/;
        $o .= $str;
        $str = ${^POSTMATCH};
    }
    $str = $o . $str;
    $str =~ s/^ //;

    return $str;
}

sub p {
    my ($k, $v) = @_;

    $v =~ s/(["\\])/\\$1/g;
    printf("  { %-15s \"%-20s },\n", $k . ',', $v . '"') or die $!;
}