| 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); |