admin/check-doc-strings

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