122a5eee |
1 | #! /usr/bin/perl -w |
2 | |
47489d8d |
3 | # $Id: accel.pl,v 1.2 2003/01/21 21:05:35 jacob Exp $ |
122a5eee |
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 |
47489d8d |
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) |
122a5eee |
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 | |
47489d8d |
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 | |
122a5eee |
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); |