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