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