contrib/accel.pl

   1 #! /usr/bin/perl -w
   2
   3 # $Id: accel.pl,v 1.2 2003/01/21 21:05:35 jacob Exp $
   4 # Grotty script to check for clashes in the PuTTY config dialog keyboard
   5 # accelerators in windlg.c, and to check the comments are still up to
   6 # date. Based on:
   7 #   windlg.c:1.201
   8 #   win_res.rc:1.59 (for global accelerators)
   9 #   winctrls.c:1.20 (for prefslist() hardcoded accelerators)
  10 # usage: accel.pl [-q] [-v] [-f windlg-alt.c]
  11
  12 use strict;
  13 use English;
  14 use Getopt::Std;
  15
  16 # Accelerators that nothing in create_controls() must use
  17 # (see win_res.rc, windlg.c:GenericMainDlgProc())
  18 my $GLOBAL_ACCEL = "acgoh";
  19
  20 my $all_ok = 1;
  21 my %opts = ();
  22
  23 # Sort a string of characters.
  24 sub sortstr {
  25     my ($str) = @_;
  26     return join("",sort(split(//,$str)));
  27 }
  28
  29 # Return duplicates in a sorted string of characters.
  30 sub dups {
  31     my ($str) = @_;
  32     my %dups = ();
  33     my $chr = undef;
  34     for (my $i=0; $i < length($str); $i++) {
  35         if (defined($chr) &&
  36             $chr eq substr($str,$i,1)) {
  37             $dups{$chr} = 1;
  38         }
  39         $chr = substr($str,$i,1);
  40     }
  41     return keys(%dups);
  42 }
  43
  44 sub mumble {
  45     print @_ unless exists($opts{q});
  46 }
  47
  48 sub whinge {
  49     mumble(@_);
  50     $all_ok = 0;
  51     return 0;
  52 }
  53
  54 # Having worked out stuff about a particular panel, check it for
  55 # plausibility.
  56 sub process_panel {
  57     my ($panel, $cmtkeys, $realkeys) = @_;
  58     my ($scmt, $sreal);
  59     my $ok = 1;
  60     $scmt  = sortstr ($cmtkeys);
  61     $sreal = sortstr ($GLOBAL_ACCEL . $realkeys);
  62     my @dups = dups($sreal);
  63     if (@dups) {
  64         $ok = whinge("$panel: accelerator clash(es): ",
  65                      join(", ", @dups), "\n") && $ok;
  66     }
  67     if ($scmt ne $sreal) {
  68         $ok = whinge("$panel: comment doesn't match reality ",
  69                      "([$GLOBAL_ACCEL] $realkeys)\n") && $ok;
  70     }
  71     if ($ok && exists($opts{v})) {
  72         mumble("$panel: ok\n");
  73     }
  74 }
  75
  76 getopts("qvf:", \%opts);
  77 my $windlg_c_name = "windlg.c";
  78 $windlg_c_name = $opts{f} if exists($opts{f});
  79
  80 open WINDLG, "<$windlg_c_name";
  81
  82 # Grotty ad-hoc parser (tm) state
  83 my $in_ctrl_fn = 0;
  84 my $seen_ctrl_fn = 0;
  85 my $panel;
  86 my $cmt_accel;
  87 my $real_accel;
  88
  89 while (<WINDLG>) {
  90     chomp;
  91     if (!$in_ctrl_fn) {
  92
  93         # Look for the start of the function we're interested in.
  94         if (m/create_controls\s*\(.*\)\s*$/) {
  95             $in_ctrl_fn = 1;
  96             $seen_ctrl_fn = 1;
  97             $panel = undef;
  98             next;
  99         }
 100
 101     } else {
 102
 103         if (m/^}\s*$/) {
 104             # We've run out of function. (Probably.)
 105             # We should process any pending panel.
 106             if (defined($panel)) {
 107                 process_panel($panel, $cmt_accel, $real_accel);
 108             }
 109             $in_ctrl_fn = 0;
 110             last;
 111         }
 112         if (m/^\s*if\s*\(panel\s*==\s*(\w+)panelstart\)/) {
 113             # New panel. Now seems like a good time to process the previous
 114             # one (if any).
 115             process_panel ($panel, $cmt_accel, $real_accel)
 116                 if defined($panel);
 117             $panel = $1;
 118             $cmt_accel = $real_accel = "";
 119             next;
 120         }
 121
 122         next unless defined($panel);
 123
 124         # Some nasty hacks to get round the conditionalised stuff
 125         # in the Session panel. This is probably the bit most likely
 126         # to break.
 127         if ($panel eq "session") {
 128             my $munch;
 129             if (m/if\s*\(backends\[\w+\].backend\s*==\s*NULL\)/) {
 130                 do { $munch = <WINDLG> } until ($munch =~ m/}\s*else\s*{/);
 131             } elsif (m/^#ifdef\s+FWHACK/) {
 132                 do { $munch = <WINDLG> } until ($munch =~ m/^#else/);
 133             }
 134         }
 135
 136         # Hack: winctrls.c:prefslist() has hard-coded "&Up" and "&Down"
 137         # buttons. Take this into account.
 138         if (m/\bprefslist *\(/) {
 139             $real_accel .= "ud";
 140         }
 141
 142         # Look for accelerator comment.
 143         if (m#/\* .* Accelerators used: (.*) \*/#) {
 144             die "aiee, multiple comments in panel" if ($cmt_accel);
 145             $cmt_accel = lc $1;
 146             $cmt_accel =~ tr/[] //d;    # strip ws etc
 147             next;
 148         }
 149
 150         # Now try to find double-quoted strings.
 151         {
 152             my $line = $ARG;
 153             # Opening quote.
 154             while ($line =~ m/"/) {
 155                 $line = $POSTMATCH;
 156                 my $str = $line;
 157                 # Be paranoid about \", since it does get used.
 158                 while ($line =~ m/(?:(\\)?"|(&)(.))/) {
 159                     $line = $POSTMATCH;
 160                     if (defined($2)) {
 161                         if ($3 ne "&") {
 162                             # Found an accelerator. (Probably.)
 163                             $real_accel .= lc($3);
 164                         }
 165                         # Otherwise, found && -- ignore.
 166                     } else {
 167                         # It's an end quote.
 168                         last unless defined($1);
 169                         # Otherwise, it's a \" quote.
 170                         # Yum.
 171                     }
 172                 }
 173             }
 174         }
 175     }
 176
 177 }
 178
 179 close WINDLG;
 180
 181 die "That didn't look anything like windlg.c to me" if (!$seen_ctrl_fn);
 182
 183 exit (!$all_ok);