| 1 | : #-*- Perl -*- |
| 2 | eval 'exec perl -S $0 ${1+"$@"}' # Portability kludge |
| 3 | if 0; |
| 4 | |
| 5 | # Author: Martin Buchholz |
| 6 | # This program is in the public domain. |
| 7 | |
| 8 | use strict; |
| 9 | use warnings; |
| 10 | use POSIX; |
| 11 | |
| 12 | (my $myName = $0) =~ s@.*/@@; my $usage=" |
| 13 | Usage: $myName |
| 14 | |
| 15 | Finds DOCSTRING arg mismatches between |
| 16 | formal parameters, docstrings, and lispref texi. |
| 17 | |
| 18 | This program is in the public domain.\n"; |
| 19 | |
| 20 | die $usage if @ARGV; |
| 21 | die $usage unless -r "src/alloc.c" && -d ".bzr" && -d "lisp"; |
| 22 | |
| 23 | my %texi_funtype; |
| 24 | my %texi_arglist; |
| 25 | |
| 26 | my %code_funtype; |
| 27 | my %code_arglist; |
| 28 | |
| 29 | sub FileContents { |
| 30 | local $/ = undef; |
| 31 | open (FILE, "< $_[0]") or die "$_[0]: $!"; |
| 32 | return scalar <FILE>; |
| 33 | } |
| 34 | |
| 35 | sub Show_details { |
| 36 | my ($show_details, $function, $parms, $docstring) = @_; |
| 37 | if ($show_details) { |
| 38 | print "function = $function $parms\n$docstring\n", "-" x 70, "\n"; |
| 39 | } |
| 40 | } |
| 41 | |
| 42 | sub Check_texi_function { |
| 43 | my ($function, $funtype, $docstring, @parms) = @_; |
| 44 | my %docstring_parm; |
| 45 | my %docstring_word; |
| 46 | my %arglist_parm; |
| 47 | my $show_details = 0; |
| 48 | |
| 49 | if (exists $texi_funtype{$function}) { |
| 50 | print "duplicate texidoc: $function @parms\n"; |
| 51 | return; # later definition likely bogus package def |
| 52 | } |
| 53 | |
| 54 | $texi_funtype{$function} = $funtype; |
| 55 | $texi_arglist{$function} = "@parms"; |
| 56 | |
| 57 | foreach my $parm (@parms) { |
| 58 | next if $parm eq '&optional' || $parm eq '&rest'; |
| 59 | $arglist_parm{$parm} = 1; |
| 60 | } |
| 61 | |
| 62 | foreach my $parm ($docstring =~ /\@var{([^{}]+)}/g) { |
| 63 | $docstring_parm{$parm} = 1; |
| 64 | } |
| 65 | |
| 66 | foreach my $hit ($docstring =~ /[^\`]\`[A-Za-z-]+\'/g) |
| 67 | { |
| 68 | print "texi \@code missing: $function: $hit\n"; |
| 69 | $show_details = 1; |
| 70 | } |
| 71 | |
| 72 | # (my $raw_docstring = $docstring) =~ s/\@var{[^{}]+}//g; |
| 73 | # $raw_docstring =~ s/[^a-zA-Z_-]+/ /g; |
| 74 | # foreach my $word (split (' ', $raw_docstring)) { |
| 75 | # if ($word =~ /^[A-Z][A-Z-]+$/) { |
| 76 | # print "Missing \@var: $function: $word\n"; |
| 77 | # } |
| 78 | # } |
| 79 | |
| 80 | foreach my $parm (keys %docstring_parm) { |
| 81 | if (! exists $arglist_parm{$parm}) { |
| 82 | print "bogus texi parm: $function: $parm\n"; |
| 83 | $show_details = 1; |
| 84 | } |
| 85 | } |
| 86 | |
| 87 | foreach my $parm (keys %arglist_parm) { |
| 88 | if (! exists $docstring_parm{$parm}) { |
| 89 | print "undocumented texi parm: $function: $parm\n"; |
| 90 | $show_details = 1; |
| 91 | } |
| 92 | } |
| 93 | |
| 94 | Show_details $show_details, $function, "@parms", $docstring; |
| 95 | } |
| 96 | |
| 97 | sub Check_function { |
| 98 | my ($function, $funtype, $docstring, @parms) = @_; |
| 99 | my %docstring_parm; |
| 100 | my %arglist_parm; |
| 101 | my $show_details = 0; |
| 102 | |
| 103 | if (exists $code_funtype{$function}) { |
| 104 | print "duplicate codedef: $function @parms\n"; |
| 105 | return; # later definition likely bogus package def |
| 106 | } |
| 107 | |
| 108 | $code_funtype{$function} = $funtype; |
| 109 | $code_arglist{$function} = "@parms"; |
| 110 | #foreach my $parm ($parms =~ /\b[a-z0-9-]{3,}\b/g) { |
| 111 | # $arglist_parm{$parm} = 1; |
| 112 | #} |
| 113 | foreach my $parm (@parms) { |
| 114 | next if $parm eq '&optional' || $parm eq '&rest'; |
| 115 | $arglist_parm{$parm} = 1; |
| 116 | } |
| 117 | my $doc_tmp = $docstring; |
| 118 | $doc_tmp =~ s/[^A-Za-z0-9_-]/ /g; |
| 119 | foreach my $parm (split (' ', $doc_tmp)) { |
| 120 | if ($parm =~ /^[A-Z][A-Z0-9-]*$/) { |
| 121 | next if $parm =~ /I18N/; |
| 122 | next if $parm =~ /M17N/; |
| 123 | $parm =~ tr[A-Z][a-z]; |
| 124 | $docstring_parm{$parm} = 1; |
| 125 | } |
| 126 | } |
| 127 | # foreach my $parm ($docstring =~ /\b[A-Z0-9-]{1,}\b/g) { |
| 128 | # next if $parm =~ /-$/; |
| 129 | # $parm =~ tr[A-Z][a-z]; |
| 130 | # $docstring_parm{$parm} = 1; |
| 131 | # } |
| 132 | foreach my $parm (keys %docstring_parm) { |
| 133 | next if $parm eq 'tty'; |
| 134 | next if $parm eq 'fsf'; |
| 135 | next if $parm eq 'note'; |
| 136 | next if $parm eq 'warning'; |
| 137 | next if $parm eq 'bug'; |
| 138 | next if $parm eq 'ascii'; |
| 139 | next if $parm eq 'iso'; |
| 140 | next if $parm eq 'and'; |
| 141 | next if $parm eq 'absolutely'; |
| 142 | next if $parm eq 'doc'; |
| 143 | next if $parm eq 'user'; |
| 144 | next if $parm eq 'not'; |
| 145 | next if $parm eq 'must'; |
| 146 | next if $parm eq 'nil'; |
| 147 | next if $parm eq 'esc'; |
| 148 | next if $parm eq 'lfd'; |
| 149 | next if $parm eq 'gpm'; |
| 150 | next if $parm eq 'primary'; |
| 151 | next if $parm eq 'secondary'; |
| 152 | next if $parm eq 'clipboard'; |
| 153 | next if length $parm < 3; |
| 154 | if (! exists $arglist_parm{$parm}) { |
| 155 | print "bogus parm: $function: $parm\n"; |
| 156 | $show_details = 1; |
| 157 | } |
| 158 | } |
| 159 | foreach my $parm (keys %arglist_parm) { |
| 160 | if (! exists $docstring_parm{$parm}) { |
| 161 | print "Undocumented parm: $function: $parm\n"; |
| 162 | $show_details = 1; |
| 163 | } |
| 164 | } |
| 165 | |
| 166 | if ($docstring !~ /[\]}!\)\.]\s*\Z/m && |
| 167 | $docstring =~ /\S/ && |
| 168 | $docstring !~ /Keywords supported/) |
| 169 | { |
| 170 | print "Missing trailing period: $function\n"; |
| 171 | $show_details = 1; |
| 172 | } |
| 173 | |
| 174 | if (exists $texi_arglist{$function} |
| 175 | and "@parms" ne $texi_arglist{$function} |
| 176 | and not ("@parms" eq 'int nargs Lisp-Object *args' |
| 177 | && $texi_arglist{$function} =~ /&rest/)) { |
| 178 | my @texi_parms = split (' ', $texi_arglist{$function}); |
| 179 | my @a = ("@parms" =~ /&optional/g); |
| 180 | my @b = ("@parms" =~ /&rest/g); |
| 181 | my @c = ("@texi_parms" =~ /&optional/g); |
| 182 | my @d = ("@texi_parms" =~ /&rest/g); |
| 183 | if (@parms != @texi_parms |
| 184 | || (@a != @c) || (@b != @d)) { |
| 185 | print "serious mismatch: $function: @parms --- @texi_parms\n"; |
| 186 | } else { |
| 187 | print "texi mismatch: $function: @parms --- $texi_arglist{$function}\n"; |
| 188 | } |
| 189 | $show_details = 1; |
| 190 | } |
| 191 | |
| 192 | if (exists $texi_funtype{$function} |
| 193 | && $texi_funtype{$function} ne $funtype) { |
| 194 | print "interactiveness mismatch: $function: $funtype --- $texi_funtype{$function}\n"; |
| 195 | $show_details = 1; |
| 196 | } |
| 197 | |
| 198 | Show_details $show_details, $function, "@parms", $docstring; |
| 199 | } |
| 200 | |
| 201 | my $lisprefdir = "doc/lispref"; |
| 202 | die "Can't find lispref texi directory.\n" unless -d $lisprefdir; |
| 203 | |
| 204 | open (FIND, "find $lisprefdir -name '*.texi' -print |") or die; |
| 205 | while (my $file = <FIND>) { |
| 206 | my @matches = ((FileContents $file) =~ |
| 207 | /\@(def(?:fn|un))([^\n]+)\n(.*?)\n\@end def(?:un|fn)/sgo); |
| 208 | # /^\@(def(?:un|fn))\s+(.*)\n([.|\n]*?)^\@end def(?:un|fn)\n/mgo); |
| 209 | while (@matches) { |
| 210 | my ($defform, $defn, $docstring) = splice (@matches, 0, 3); |
| 211 | #print "defform = $defform\n"; |
| 212 | #print "defn = $defn\n"; |
| 213 | #print "docstring = $docstring\n"; |
| 214 | my ($function, @parms, $funtype); |
| 215 | if ($defform eq 'defun') { |
| 216 | ($funtype, $function, @parms) = ('Function', split (' ', $defn)); |
| 217 | } else { |
| 218 | die unless $defform eq 'deffn'; |
| 219 | ($funtype, $function, @parms) = split (' ', $defn); |
| 220 | } |
| 221 | next if $funtype eq '{Syntax' or $funtype eq '{Prefix'; |
| 222 | |
| 223 | Check_texi_function $function, $funtype, $docstring, @parms; |
| 224 | } |
| 225 | } |
| 226 | |
| 227 | open (FIND, "find src -name '*.c' -print |") or die; |
| 228 | while (my $file = <FIND>) { |
| 229 | my @matches = |
| 230 | ((FileContents $file) =~ |
| 231 | /\bDEFUN\s*\(\s*\"((?:[^\\\"]|\\.)+)\"\s*,\s*\S+\s*,\s*(\S+)\s*,\s*(\S+)\s*,\s*((?:0|\"(?:(?:[^\\\"]|\\.)*)\"))\s*,\s*\/\*(.*?)\*\/\s*\(([^()]*)\)\)/sgo); |
| 232 | while (@matches) { |
| 233 | my ($function, $minargs, $maxargs, $interactive, $docstring, $parms) = splice (@matches, 0, 6); |
| 234 | $docstring =~ s/^\n+//s; |
| 235 | $docstring =~ s/\n+$//s; |
| 236 | $parms =~ s/,/ /g; |
| 237 | my @parms = split (' ',$parms); |
| 238 | for (@parms) { tr/_/-/; s/-$//; } |
| 239 | if ($parms !~ /Lisp_Object/) { |
| 240 | if ($minargs < @parms) { |
| 241 | if ($maxargs =~ /^\d+$/) { |
| 242 | die unless $maxargs eq @parms; |
| 243 | splice (@parms, $minargs, 0, '&optional'); |
| 244 | } |
| 245 | } |
| 246 | } |
| 247 | my $funtype = ($interactive =~ /\"/ ? 'Command' : 'Function'); |
| 248 | Check_function $function, $funtype, $docstring, @parms; |
| 249 | } |
| 250 | } |
| 251 | |
| 252 | my @pkgs; |
| 253 | if (-d "../xemacs-packages") { |
| 254 | @pkgs = qw (libs/edebug libs/xemacs-base comm/eudc oa/edit-utils); |
| 255 | } else { |
| 256 | @pkgs = (); |
| 257 | } |
| 258 | for (@pkgs) { s@^@../xemacs-packages/@; } |
| 259 | open (FIND, "find lisp @pkgs -name '*.el' -print |") or die; |
| 260 | while (my $file = <FIND>) { |
| 261 | my $contents = FileContents $file; |
| 262 | $contents =~ s/(?:\s|;);.*//mog; |
| 263 | my @matches = |
| 264 | ($contents =~ |
| 265 | /\((def(?:un|subst|macro))\s+(\S+)\s+\(([^()]*)\)\s+\"((?:[^\\\"]|\\.)+)\"(.*?)\)/sgo); |
| 266 | while (@matches) { |
| 267 | my ($defform, $function, $parms, $docstring, $code_fragment) = splice (@matches, 0, 5); |
| 268 | |
| 269 | my $funtype = |
| 270 | $defform eq 'defmacro' ? 'Macro' : |
| 271 | $code_fragment =~ /^\s*\(interactive\b/so ? 'Command' : |
| 272 | 'Function'; |
| 273 | |
| 274 | $docstring =~ s/^\n+//s; |
| 275 | $docstring =~ s/\n+$//s; |
| 276 | |
| 277 | my @parms = split (' ', $parms); |
| 278 | |
| 279 | Check_function $function, $funtype, $docstring, @parms; |
| 280 | } |
| 281 | } |
| 282 | |
| 283 | open (FIND, "find lisp @pkgs -name '*.el' -print |") or die; |
| 284 | while (my $file = <FIND>) { |
| 285 | my $contents = FileContents $file; |
| 286 | $contents =~ s/(?:\s|;);.*//mog; |
| 287 | |
| 288 | my @matches = ($contents =~ /^\((?:defalias|fset|define-function)\s+\'([A-Za-z0-9_-]+)\s+\'([A-Za-z0-9_-]+)/mog); |
| 289 | while (@matches) { |
| 290 | my ($alias, $aliasee) = splice (@matches, 0, 2); |
| 291 | print "alias $alias aliasee $aliasee\n"; |
| 292 | if (exists $code_funtype{$aliasee}) { $code_funtype{$alias} = $code_funtype{$aliasee}; } |
| 293 | if (exists $code_arglist{$aliasee}) { $code_arglist{$alias} = $code_arglist{$aliasee}; } |
| 294 | } |
| 295 | } |
| 296 | |
| 297 | foreach my $fun (sort keys %texi_funtype) { |
| 298 | if (not exists $code_funtype{$fun}) { |
| 299 | print "nuke-this-doc: $fun $texi_funtype{$fun}\n"; |
| 300 | } |
| 301 | } |
| 302 | |