gnu/usr.bin/man/makewhatis/makewhatis.perl

   1 #!/usr/bin/perl
   2 #
   3 # Copyright (c) 1994-1996 Wolfram Schneider <wosch@FreeBSD.org>. Berlin.
   4 # All rights reserved.
   5 #
   6 # Redistribution and use in source and binary forms, with or without
   7 # modification, are permitted provided that the following conditions
   8 # are met:
   9 # 1. Redistributions of source code must retain the above copyright
  10 #    notice, this list of conditions and the following disclaimer.
  11 # 2. Redistributions in binary form must reproduce the above copyright
  12 #    notice, this list of conditions and the following disclaimer in the
  13 #    documentation and/or other materials provided with the distribution.
  14 #
  15 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  16 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  17 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 # ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
  19 # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  21 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  22 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  23 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  24 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  25 # SUCH DAMAGE.
  26 #
  27 # makewhatis -- update the whatis database in the man directories.
  28 #
  29 # $FreeBSD: src/gnu/usr.bin/man/makewhatis/makewhatis.perl,v 1.21.2.4 2002/03/29 15:38:09 ru Exp $
  30 # $DragonFly: src/gnu/usr.bin/man/makewhatis/Attic/makewhatis.perl,v 1.2 2003/06/17 04:25:46 dillon Exp $
  31
  32
  33 sub usage {
  34
  35     warn <<EOF;
  36 usage: makewhatis [-a|-append] [-h|-help] [-i|-indent column] [-L|-locale]
  37                   [-n|-name name] [-o|-outfile file] [-v|-verbose]
  38                   [directories ...]
  39 EOF
  40     exit 1;
  41 }
  42
  43
  44 # Format output
  45 sub open_output {
  46     local($dir) = @_;
  47
  48     die "Name for whatis is empty\n" if $whatis_name eq "";
  49
  50     if ($outfile) {             # Write all Output to $outfile
  51         $whatisdb = $outfile;
  52     } else {            # Use man/whatis
  53         $whatisdb = $dir . "/$whatis_name.tmp";
  54     }
  55     $tmp = $whatisdb;           # for signals
  56
  57     # Array of all entries
  58     @a = ();
  59
  60     # Append mode
  61     if ($append) {
  62         local($file) = $whatisdb;
  63         $file =~ s/\.tmp$// if !$outfile;
  64
  65         if (open(A, "$file")) {
  66             warn "Open $file for append mode\n" if $verbose;
  67             while(<A>) {
  68                 push(@a, $_);
  69             }
  70             close A;
  71         }
  72
  73         else {
  74             warn "$whatisdb: $!\n" if lstat($file) && $verbose; #
  75         }
  76         undef $file;
  77     }
  78
  79
  80     warn "Open $whatisdb\n" if $verbose;
  81     if (!open(A, "> $whatisdb")) {
  82         die "$whatisdb: $!\n" if $outfile;
  83
  84         warn "$whatisdb: $!\n"; $err++; return 0;
  85     }
  86
  87     select A;
  88     return 1;
  89 }
  90
  91 sub close_output {
  92     local($success) = @_;
  93     local($w) = $whatisdb;
  94     local($counter) = 0;
  95     local($i, $last,@b);
  96
  97     $w =~ s/\.tmp$//;
  98     if ($success) {             # success
  99         # uniq
 100         warn "\n" if $verbose && $pointflag;
 101         warn "sort -u > $whatisdb\n" if $verbose;
 102         foreach $i (sort @a) {
 103             if ($i ne $last) {
 104                 push(@b, $i);
 105             }
 106             $last =$i;
 107         }
 108
 109         $counter = $#b + 1;
 110         print @b; close A; select STDOUT;
 111
 112         if (!$outfile) {
 113             warn "Rename $whatisdb to $w\n" if $verbose;
 114             rename($whatisdb, $w) || warn "rename $whatisdb $w\n";
 115             $counter_all += $counter;
 116             warn "$counter entries in $w\n" if $verbose;
 117         } else {
 118             $counter_all = $counter;
 119         }
 120     } else {            # building whatisdb failed
 121         unlink($whatisdb);
 122         warn "building whatisdb: $whatisdb failed\n" if $verbose;
 123     }
 124     return 1;
 125 }
 126
 127 sub parse_subdir {
 128     local($dir) = @_;
 129     local($file, $dev,$ino);
 130
 131     warn "\n" if $pointflag;
 132     warn "traverse $dir\n" if $verbose;
 133     $pointflag = 0;
 134
 135     if (!opendir(M, $dir)) {
 136         warn "$dir: $!\n"; $err++; return 0;
 137     }
 138
 139     $| = 1 if $verbose;
 140     foreach $file (readdir(M)) {
 141         next if $file =~ /^(\.|\.\.)$/;
 142
 143         ($dev, $ino) = ((stat("$dir/$file"))[01]);
 144         if (-f _) {
 145             if ($man_red{"$dev.$ino"}) {
 146                 # Link
 147                 print STDERR "+" if $verbose;
 148                 $pointflag++ if $verbose;
 149             } else {
 150                 &manual("$dir/$file");
 151             }
 152             $man_red{"$dev.$ino"} = 1;
 153         } elsif (! -d _) {
 154             warn "Cannot find file: $dir/$file\n"; $err++;
 155         }
 156     }
 157     closedir M;
 158     return 1;
 159 }
 160
 161 # read man directory
 162 sub parse_dir {
 163     local($dir) = @_;
 164     local($subdir, $file);
 165
 166     # clean up, in case mandir and subdirs are called simultaneously
 167     # e. g.:  ~/man/man1 ~/man/man2 ~/man
 168     #~/man/ man1 and ~/man/man2 are a subset of ~/man
 169     foreach $file (keys %man_red) {
 170         delete $man_red{$file};
 171     }
 172
 173     if ($dir =~ /man/) {
 174         warn "\n" if $verbose && $pointflag;
 175         warn "open manpath directory ``$dir''\n" if $verbose;
 176         $pointflag = 0;
 177         if (!opendir(DIR, $dir)) {
 178             warn "opendir ``$dir'':$!\n"; $err = 1; return 0;
 179         }
 180         foreach $subdir (sort(readdir(DIR))) {
 181             if ($subdir =~ /^man\w+$/) {
 182                 $subdir = "$dir/$subdir";
 183                 &parse_subdir($subdir);
 184                 &parse_subdir($subdir) if -d ($subdir .= "/${machine}");
 185             }
 186         }
 187         closedir DIR
 188
 189     } elsif ($dir =~ /man\w+$/) {
 190         &parse_subdir($dir);
 191     } else {
 192         warn "Assume ``$dir'' is not a man directory.\n";
 193         $err = 1; return 0;
 194     }
 195     return 1;
 196 }
 197
 198 sub dir_redundant {
 199     local($dir) = @_;
 200
 201     local($dev,$ino) = (stat($dir))[0..1];
 202
 203     if ($dir_redundant{"$dev.$ino"}) {
 204         warn "$dir is equal to: $dir_redundant{\"$dev.$ino\"}\n" if $verbose;
 205         return 0;
 206     }
 207     $dir_redundant{"$dev.$ino"} = $dir;
 208     return 1;
 209 }
 210
 211
 212 # ``/usr/man/man1/foo.l'' -> ``l''
 213 sub ext {
 214     local($filename) = @_;
 215     local($extension) = $filename;
 216
 217     $extension =~ s/$ext$//g;   # strip .gz
 218     $extension =~ s/.*\///g;    # basename
 219
 220     if ($extension !~ m%[^/]+\.[^.]+$%) {       # no dot
 221         $extension = $filename;
 222         #$extension =~ s|/[^/]+$||;
 223         $extension =~ s%.*man([^/]+)/[^/]+%$1%; # last character
 224         warn "\n" if $verbose && $pointflag;
 225         warn "$filename has no extension, try section ``$extension''\n"
 226             if $verbose;
 227         $pointflag = 0;
 228     } else {
 229         $extension =~ s/.*\.//g; # foo.bla.1 -> 1
 230     }
 231     return "$extension";
 232 }
 233
 234 # ``/usr/man/man1/foo.1'' -> ``foo''
 235 sub name {
 236     local($name) = @_;
 237
 238     $name =~ s=.*/==;
 239     $name =~ s=$ext$==o;
 240     $name =~ s=\.[^\.]+$==;
 241
 242     return "$name";
 243 }
 244
 245 # output
 246 sub out {
 247     local($list) = @_;
 248     local($delim) = " - ";
 249     $_ = $list;
 250
 251     # delete italic etc.
 252     s/^\.[^ -]+[ -]+//;
 253     s/\\\((em|mi)//;
 254     s/\\f[IRBP]//g;
 255     s/\\\*p//g;
 256     s/\(OBSOLETED\)[ ]?//;
 257     s/\\&//g;
 258     s/^\@INDOT\@//;
 259     s/[\"\\]//g;                #"
 260     s/[. \t-]+$//;
 261
 262     s/ / - / unless / - /;
 263     ($man,$desc) = split(/ - /);
 264
 265     $man = $name unless $man;
 266     $man =~ s/[,. ]+$//;
 267     $man =~ s/,/($extension),/g;
 268     $man .= "($extension)";
 269
 270     &manpagename;
 271
 272     $desc =~ s/^[ \t]+//;
 273
 274     for($i = length($man); $i < $indent && $desc; $i++) {
 275         $man .= ' ';
 276     }
 277     if ($desc) {
 278         push(@a, "$man$delim$desc\n");
 279     } else {
 280         push(@a, "$man\n");
 281     }
 282 }
 283
 284 # The filename of manual page is not a keyword.
 285 # This is bad, because you don't find the manpage
 286 # whith: $ man <section> <keyword>
 287 #
 288 # Add filename if a) filename is not a keyword and b) no keyword(s)
 289 # exist as file in same mansection
 290 #
 291 sub manpagename {
 292     foreach (split(/,\s+/, $man)) {
 293         s/\(.+//;
 294         # filename is keyword
 295         return if $name eq $_;
 296     }
 297
 298     local($f) = $file;  $f =~ s%/*[^/]+$%%;             # dirname
 299     local($e) = $file;  $e =~ s/$ext$//;  $e =~ s%.*(\.[^.]+)$%$1%; # .1
 300
 301     foreach (split(/,\s+/, $man)) {
 302         s/\(.+//;
 303
 304         # a keyword exist as file
 305         return if -e "$f/$_$e" || -e "$f/$_$e$ext";
 306     }
 307
 308     $man = "$name($extension), $man";
 309 }
 310
 311 # looking for NAME
 312 sub manual {
 313     local($file) = @_;
 314     local($list, $desc, $extension);
 315     local($ofile) = $file;
 316
 317     # Compressed man pages
 318     if ($ofile =~ /$ext$/) {
 319         $ofile = "gzcat $file |";
 320         print STDERR "*" if $verbose;
 321     } else {
 322         print STDERR "." if $verbose;
 323     }
 324     $pointflag++ if $verbose;
 325
 326     if (!open(F, "$ofile")) {
 327         warn "Cannot open file: $ofile\n"; $err++;
 328         return 0;
 329     }
 330     # extension/section
 331     $extension = &ext($file);
 332     $name = &name($file);
 333
 334     $section_name = "NAME|Name|NAMN|BEZEICHNUNG|Ì¾¾Î|îáú÷áîéå";
 335
 336     local($source) = 0;
 337     local($list);
 338     while(<F>) {
 339         # ``man'' style pages
 340         # &&: it takes you only half the user time, regexp is slow!!!
 341         if (/^\.SH/ && /^\.SH[ \t]+["]?($section_name)["]?/) {
 342             #while(<F>) { last unless /^\./ } # Skip
 343             #chop; $list = $_;
 344             while(<F>) {
 345                 last if /^\.SH[ \t]/;
 346                 chop;
 347                 s/^\.IX\s.*//;            # delete perlpod garbage
 348                 s/^\.[A-Z]+[ ]+[0-9]+$//; # delete commands
 349                 s/^\.[A-Za-z]*[ \t]*//;   # delete commands
 350                 s/^\.\\".*$//;            #" delete comments
 351                 s/^[ \t]+//;
 352                 if ($_) {
 353                     $list .= $_;
 354                     $list .= ' ';
 355                 }
 356             }
 357             while(<F>) { }      # skip remaining input to avoid pipe errors
 358             &out($list); close F; return 1;
 359         } elsif (/^\.Sh/ && /^\.Sh[ \t]+["]?($section_name)["]?/) {
 360             # ``doc'' style pages
 361             local($flag) = 0;
 362             while(<F>) {
 363                 last if /^\.Sh/;
 364                 chop;
 365                 s/^\.\\".*$//;            #" delete comments
 366                 next if /^\.[ \t]*$/;     # skip empty calls
 367                 if (/^\.Nm/) {
 368                     s/^\.Nm[ \t]*//;
 369                     s/ ,/,/g;
 370                     s/[ \t]+$//;
 371                     $list .= $_;
 372                     $list .= ' ';
 373                 } else {
 374                     $list .= '- ' if (!$flag && !/^- /);
 375                     $flag++;
 376                     if (/^\.Xr/) {
 377                         split;
 378                         $list .= @_[1];
 379                         $list .= "(@_[2])" if @_[2];
 380                     } else {
 381                         s/^\.([A-Z][a-z])?[ \t]*//;
 382                         s/[ \t]+$//;
 383                         $list .= $_;
 384                     }
 385                     $list .= ' ';
 386                 }
 387             }
 388             while(<F>) { }      # skip remaining input to avoid pipe errors
 389             &out($list); close F; return 1;
 390
 391         } elsif(/^\.so/ && /^\.so[ \t]+man/) {
 392             while(<F>) { }      # skip remaining input to avoid pipe errors
 393             close F; return 1;
 394         }
 395     }
 396     if (!$source && $verbose) {
 397         warn "\n" if $pointflag;
 398         warn "Maybe $file is not a manpage\n" ;
 399         $pointflag = 0;
 400     }
 401     return 0;
 402 }
 403
 404 # make relative path to absolute path
 405 sub absolute_path {
 406     local(@dirlist) = @_;
 407     local($pwd, $dir, @a);
 408
 409     $pwd = $ENV{'PWD'};
 410     foreach $dir (@dirlist) {
 411         if ($dir !~ "^/") {
 412             chop($pwd = `pwd`) if (!$pwd || $pwd !~ /^\//);
 413             push(@a, "$pwd/$dir");
 414         } else {
 415             push(@a, $dir);
 416         }
 417     }
 418     return @a;
 419 }
 420
 421 # strip unused '/'
 422 # e.g.: //usr///home// -> /usr/home
 423 sub stripdir {
 424     local($dir) = @_;
 425
 426     $dir =~ s|/+|/|g;           # delete double '/'
 427     $dir =~ s|/$||;             # delete '/' at end
 428     $dir =~ s|/(\.\/)+|/|g;     # delete ././././
 429
 430     $dir =~ s|/+|/|g;           # delete double '/'
 431     $dir =~ s|/$||;             # delete '/' at end
 432     $dir =~ s|/\.$||;           # delete /. at end
 433     return $dir if $dir ne "";
 434     return '/';
 435 }
 436
 437 sub variables {
 438     $verbose = 0;               # Verbose
 439     $indent = 24;               # Indent for description
 440     $outfile = 0;               # Don't write to ./whatis
 441     $whatis_name = "whatis";    # Default name for DB
 442     $append = 0;                # Don't delete old entries
 443     $locale = 0;                # Build DB only for localized man directories
 444     chomp($machine = $ENV{'MACHINE'} || `uname -m`);
 445
 446     # choose localized man directories suffix.
 447     $local_suffix = $ENV{'LC_ALL'} || $ENV{'LC_CTYPE'} || $ENV{'LANG'};
 448
 449     # if no argument for directories given
 450     @defaultmanpath = ( '/usr/share/man' );
 451
 452     $ext = '.gz';               # extension
 453     umask(022);
 454
 455     $err = 0;                   # exit code
 456     $whatisdb = '';
 457     $counter_all = 0;
 458     $dir_redundant = '';        # redundant directories
 459     $man_red = '';              # redundant man pages
 460     @a = ();                    # Array for output
 461
 462     # Signals
 463     $SIG{'INT'} = 'Exit';
 464     $SIG{'HUP'} = 'Exit';
 465     $SIG{'TRAP'} = 'Exit';
 466     $SIG{'QUIT'} = 'Exit';
 467     $SIG{'TERM'} = 'Exit';
 468     $tmp = '';                  # tmp file
 469
 470     $ENV{'PATH'} = "/bin:/usr/bin:$ENV{'PATH'}";
 471 }
 472
 473 sub  Exit {
 474     unlink($tmp) if $tmp ne ""; # unlink if a filename
 475     die "$0: die on signal SIG@_\n";
 476 }
 477
 478 sub parse {
 479     local(@argv) = @_;
 480     local($i);
 481
 482     while ($_ = $argv[0], /^-/) {
 483         shift @argv;
 484         last if /^--$/;
 485         if    (/^--?(v|verbose)$/)      { $verbose = 1 }
 486         elsif (/^--?(h|help|\?)$/)      { &usage }
 487         elsif (/^--?(o|outfile)$/)      { $outfile = $argv[0]; shift @argv }
 488         elsif (/^--?(f|format|i|indent)$/) { $i = $argv[0]; shift @argv }
 489         elsif (/^--?(n|name)$/)         { $whatis_name = $argv[0];shift @argv }
 490         elsif (/^--?(a|append)$/)       { $append = 1 }
 491         elsif (/^--?(L|locale)$/)       { $locale = 1 }
 492         else                            { &usage }
 493     }
 494     warn "Localized man directory suffix is ``$local_suffix''\n"
 495         if $verbose && $locale;
 496
 497     if ($i ne "") {
 498         if ($i =~ /^[0-9]+$/) {
 499             $indent = $i;
 500         } else {
 501             warn "Ignoring wrong indent value: ``$i''\n";
 502         }
 503     }
 504
 505     return &absolute_path(@argv) if $#argv >= 0;
 506     return @defaultmanpath if $#defaultmanpath >= 0;
 507
 508     warn "Missing directories\n"; &usage;
 509 }
 510
 511 # Process man directory
 512 sub process_dir {
 513   local($dir) = @_;
 514
 515   $dir = &stripdir($dir);
 516   &dir_redundant($dir) && &parse_dir($dir);
 517 }
 518
 519 # Process man directory and store output to file
 520 sub process_dir_to_file {
 521   local($dir) = @_;
 522
 523   $dir = &stripdir($dir);
 524   &dir_redundant($dir) &&
 525       &close_output(&open_output($dir) && &parse_dir($dir));
 526 }
 527
 528 # convert locale name to short notation (ru_RU.KOI8-R -> ru.KOI8-R)
 529 sub short_locale_name {
 530   local($lname) = @_;
 531
 532   $lname =~ s|_[A-Z][A-Z]||;
 533   warn "short locale name is $lname\n" if $verbose && $locale;
 534   return $lname;
 535 }
 536
 537 ##
 538 ## Main
 539 ##
 540
 541 &variables;
 542 # allow colons in dir: ``makewhatis dir1:dir2:dir3''
 543 @argv = &parse(split(/[: ]/, join($", @ARGV))); # "
 544
 545 if ($outfile) {
 546     if(&open_output($outfile)){
 547         foreach $dir (@argv) {
 548             # "Local only" flag set ? Yes ...
 549             if ($locale) {
 550                 if ($local_suffix ne "") {
 551                      &process_dir($dir.'/'.$local_suffix);
 552                      &process_dir($dir.'/'.&short_locale_name($local_suffix));
 553                 }
 554             } else {
 555                 &process_dir($dir);
 556             }
 557         }
 558     }
 559     &close_output(1);
 560 } else {
 561     foreach $dir (@argv) {
 562         # "Local only" flag set ? Yes ...
 563         if ($locale) {
 564             if ($local_suffix ne "") {
 565               &process_dir_to_file($dir.'/'.$local_suffix);
 566               &process_dir_to_file($dir.'/'.&short_locale_name($local_suffix));
 567             }
 568         } else {
 569            &process_dir_to_file($dir);
 570         }
 571     }
 572 }
 573
 574 warn "Total entries: $counter_all\n" if $verbose && ($#argv > 0 || $outfile);
 575 exit $err;