git.distorted.org.uk Git - u/mdw/putty/blob - contrib/accel.pl

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