Grotty script to sanity-check the accelerator keys in windlg.c.

(private RCS rev 1.4)

[originally from svn r1585]

contrib/accel.pl

@@ -0,0 +1,174 @@
+#! /usr/bin/perl -w
+
+# $Id: accel.pl,v 1.1 2002/03/10 21:56:55 jacob Exp $
+# Grotty script to check for clashes in the PuTTY config dialog keyboard
+# accelerators in windlg.c, and to check the comments are still up to
+# date. Based on windlg.c:1.177 & win_res.rc:1.56.
+# usage: accel.pl [-q] [-v] [-f windlg-alt.c]
+
+use strict;
+use English;
+use Getopt::Std;
+
+# Accelerators that nothing in create_controls() must use
+# (see win_res.rc, windlg.c:GenericMainDlgProc())
+my $GLOBAL_ACCEL = "acgoh";
+
+my $all_ok = 1;
+my %opts = ();
+
+# Sort a string of characters.
+sub sortstr {
+    my ($str) = @_;
+    return join("",sort(split(//,$str)));
+}
+
+# Return duplicates in a sorted string of characters.
+sub dups {
+    my ($str) = @_;
+    my %dups = ();
+    my $chr = undef;
+    for (my $i=0; $i < length($str); $i++) {
+        if (defined($chr) &&
+            $chr eq substr($str,$i,1)) {
+            $dups{$chr} = 1;
+        }
+        $chr = substr($str,$i,1);
+    }
+    return keys(%dups);
+}
+
+sub mumble {
+    print @_ unless exists($opts{q});
+}
+
+sub whinge {
+    mumble(@_);
+    $all_ok = 0;
+    return 0;
+}
+
+# Having worked out stuff about a particular panel, check it for
+# plausibility.
+sub process_panel {
+    my ($panel, $cmtkeys, $realkeys) = @_;
+    my ($scmt, $sreal);
+    my $ok = 1;
+    $scmt  = sortstr ($cmtkeys);
+    $sreal = sortstr ($GLOBAL_ACCEL . $realkeys);
+    my @dups = dups($sreal);
+    if (@dups) {
+        $ok = whinge("$panel: accelerator clash(es): ",
+                     join(", ", @dups), "\n") && $ok;
+    }
+    if ($scmt ne $sreal) {
+        $ok = whinge("$panel: comment doesn't match reality ",
+                     "([$GLOBAL_ACCEL] $realkeys)\n") && $ok;
+    }
+    if ($ok && exists($opts{v})) {
+        mumble("$panel: ok\n");
+    }
+}
+
+getopts("qvf:", \%opts);
+my $windlg_c_name = "windlg.c";
+$windlg_c_name = $opts{f} if exists($opts{f});
+
+open WINDLG, "<$windlg_c_name";
+
+# Grotty ad-hoc parser (tm) state
+my $in_ctrl_fn = 0;
+my $seen_ctrl_fn = 0;
+my $panel;
+my $cmt_accel;
+my $real_accel;
+
+while (<WINDLG>) {
+    chomp;
+    if (!$in_ctrl_fn) {
+
+        # Look for the start of the function we're interested in.
+        if (m/create_controls\s*\(.*\)\s*$/) {
+            $in_ctrl_fn = 1;
+            $seen_ctrl_fn = 1;
+            $panel = undef;
+            next;
+        }
+
+    } else {
+
+        if (m/^}\s*$/) {
+            # We've run out of function. (Probably.)
+            # We should process any pending panel.
+            if (defined($panel)) {
+                process_panel($panel, $cmt_accel, $real_accel);
+            }
+            $in_ctrl_fn = 0;
+            last;
+        }
+        if (m/^\s*if\s*\(panel\s*==\s*(\w+)panelstart\)/) {
+            # New panel. Now seems like a good time to process the previous
+            # one (if any).
+            process_panel ($panel, $cmt_accel, $real_accel)
+                if defined($panel);
+            $panel = $1;
+            $cmt_accel = $real_accel = "";
+            next;
+        }
+
+        next unless defined($panel);
+
+        # Some nasty hacks to get round the conditionalised stuff
+        # in the Session panel. This is probably the bit most likely
+        # to break.
+        if ($panel eq "session") {
+            my $munch;
+            if (m/if\s*\(backends\[\w+\].backend\s*==\s*NULL\)/) {
+                do { $munch = <WINDLG> } until ($munch =~ m/}\s*else\s*{/);
+            } elsif (m/^#ifdef\s+FWHACK/) {
+                do { $munch = <WINDLG> } until ($munch =~ m/^#else/);
+            }
+        }
+
+        # Look for accelerator comment.
+        if (m#/\* .* Accelerators used: (.*) \*/#) {
+            die "aiee, multiple comments in panel" if ($cmt_accel);
+            $cmt_accel = lc $1;
+            $cmt_accel =~ tr/[] //d;    # strip ws etc
+            next;
+        }
+
+        # Now try to find double-quoted strings.
+        {
+            my $line = $ARG;
+            # Opening quote.
+            while ($line =~ m/"/) {
+                $line = $POSTMATCH;
+                my $str = $line;
+                # Be paranoid about \", since it does get used.
+                while ($line =~ m/(?:(\\)?"|(&)(.))/) {
+                    $line = $POSTMATCH;
+                    if (defined($2)) {
+                        if ($3 ne "&") {
+                            # Found an accelerator. (Probably.)
+                            $real_accel .= lc($3);
+                        }
+                        # Otherwise, found && -- ignore.
+                    } else {
+                        # It's an end quote.
+                        last unless defined($1);
+                        # Otherwise, it's a \" quote.
+                        # Yum.
+                    }
+                }
+            }
+        }
+    }
+
+}
+
+close WINDLG;
+
+die "That didn't look anything like windlg.c to me" if (!$seen_ctrl_fn);
+
+exit (!$all_ok);