contrib/groffer/man.pl

   1 #! /usr/bin/env perl
   2
   3 # groffer - display groff files
   4
   5 # Source file position: <groff-source>/contrib/groffer/man.pl
   6 # Installed position: <prefix>/lib/groff/groffer/man.pl
   7
   8 # Copyright (C) 2006-2018 Free Software Foundation, Inc.
   9 # Written by Bernd Warken <groff-bernd.warken-72@web.de>.
  10
  11 # This file is part of 'groffer', which is part of 'groff'.
  12
  13 # 'groff' is free software; you can redistribute it and/or modify it
  14 # under the terms of the GNU General Public License as published by
  15 # the Free Software Foundation, either version 2 of the License, or
  16 # (at your option) any later version.
  17
  18 # 'groff' is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program.  If not, see
  25 # <http://www.gnu.org/licenses/gpl-2.0.html>.
  26
  27 ########################################################################
  28
  29 use strict;
  30 use warnings;
  31
  32 ########################################################################
  33 # functions for apropos, man, whatis
  34 ########################################################################
  35
  36 ##########
  37 # apropos_filespec()
  38 #
  39 # Compose temporary file for filspec.
  40 #
  41 # Globals:  in: $main::Opt{'APROPOS'}, $main::Special_Setup, $main::Filespec_Arg,
  42 #               $main::Apropos_Prog, $main::Opt{'APROPOS_SECTIONS'}, $main::Opt{'SECTIONS'}
  43 #          out: $main::Special_Filespec
  44 #
  45 sub apropos_filespec {
  46   return 0 unless $main::Opt{'APROPOS'};
  47   die 'apropos_filespec(): apropos_setup() must be run first;'
  48     unless $main::Special_Setup;
  49   die 'apropos_filespec(): no $main::Filespec_Arg is set;'
  50     unless defined $main::Filespec_Arg;
  51   $main::Special_Filespec = 1;
  52
  53   my $s;
  54   if ($main::No_Filespecs) {
  55     &to_tmp_line('.SH no filespec');
  56     $s = `$main::Apropos_Prog`;
  57     $s =~ s/^/\\\&/;
  58     &to_tmp_line($s);
  59     return 1;
  60   }
  61
  62   $s = $main::Filespec_Arg;
  63   $s =~ s/[^\\]-/\\-/g;
  64   &to_tmp_line(".SH $s");
  65
  66   if ( $main::Opt{'APROPOS_SECTIONS'} ) {
  67     $s = qr/^[^\(]*\([$main::Opt{'APROPOS_SECTIONS'}]/;
  68   } else {
  69     if ( $main::Opt{'SECTIONS'} ) {
  70       $s = $main::Opt{'SECTIONS'};
  71       $s = qr/^[^\(]*\([$s]/;
  72     } else {
  73       $s = qr/^.*\(.+\).*$/;
  74     }
  75   }
  76
  77 ### apropos_filespec()
  78   my $filespec = $main::Filespec_Arg;
  79   $filespec =~ s#/#\\/#g;
  80   $filespec =~ s#\.#\\./#g;
  81   my @ap;
  82   foreach ( `$main::Apropos_Prog $main::Filespec_Arg 2>$main::Dev_Null` ) {
  83     chomp;
  84     if (/^$filespec:\s/) {      # for error messages of this script
  85       my $line = $_;
  86       $line =~ s/^(.*)$/\\\&$1/s;
  87       push @ap, $line;
  88     }
  89     if (/$s/) {
  90       push @ap, $_;
  91     }
  92   }
  93   my @res;
  94   foreach (sort @ap) {
  95     s/^
  96       ([^\(]+\(+[$main::Man{'AUTO_SEC_CHARS'}][^\)]*\)+)
  97       (\s*-*)*\s*
  98       (.*)
  99       $/.br\n.TP 15\n.BR "$1"\n\\\&$3\n/sx;
 100     push @res, $_;
 101   }
 102   &to_tmp_line(@res);
 103   1;
 104 }                               # apropos_filespec()
 105
 106
 107 ##########
 108 # apropos_setup()
 109 #
 110 # Setup for the --apropos* options, just 2 global variables are set.
 111 #
 112 # Globals:  in: $main::Opt{'APROPOS'}
 113 #          out: $main::Special_Setup, $main::Apropos_Prog
 114 #
 115 sub apropos_setup {
 116   return 0 unless $main::Opt{'APROPOS'};
 117   if ( &where_is_prog('apropos') ) {
 118     $main::Apropos_Prog = 'apropos';
 119   } elsif ( &where_is_prog('man') ) {
 120     if (! system("man --apropos man >$main::Dev_Null 2>$main::Dev_Null")) {
 121       $main::Apropos_Prog = 'man --apropos';
 122     } elsif (! system("man -k man >$main::Dev_Null 2>$main::Dev_Null")) {
 123       $main::Apropos_Prog = 'man --k';
 124     }
 125   }                             # test man
 126   die 'apropos_setup(): no apropos program available;'
 127     unless $main::Apropos_Prog;
 128   &to_tmp_line('.TH GROFFER APROPOS');
 129   $main::Special_Setup = 1;
 130   $main::Opt{'TITLE'} = 'apropos' unless $main::Opt{'TITLE'};
 131   1;
 132 }                               # apropos_setup()
 133
 134
 135 ##########
 136 # is_man(<man_sec_ext-hash-ref>)
 137 #
 138 # Test whether the argument hash exists as man page (from is_man()).
 139 #
 140 # Globals: in: $main::Man{AUTO_SEC_CHARS},$main::Man{SEC_CHARS},
 141 #              $main::Man{EXT}, $tmpdir
 142 #         out: $main::Manspec
 143 #
 144 # Arguments: 1, a hash reference with keys 'name', 'sec', 'ext', where
 145 #               'sec' is a string of one or several section characters
 146 #
 147 sub is_man {
 148   my $n = @_;
 149   die "is_man(): one argument is needed, you used $n;"
 150     unless $n == 1;
 151   die "is_man(): the argument is not a hash reference '$_[0]';"
 152     if ref($_[0]) ne 'HASH';
 153   die 'is_man(): temporary directory is not set;' unless $main::tmpdir;
 154   die 'is_man(): man_setup() must be run first;' unless $main::Man{'IS_SETUP'};
 155
 156   my $name = $_[0]->{'name'};
 157   unless ($name) {
 158     $main::Manspec = '';
 159     return 0;
 160   }
 161
 162   my $sec;
 163   $sec = $_[0]->{'sec'};
 164   $sec = $main::Man{'SEC_CHARS'} unless $sec;
 165   $sec = $main::Man{'AUTO_SEC_CHARS'} unless $sec;
 166   $sec = '' unless defined $sec;
 167   # take care, $sec may be several sections
 168
 169 ### is_man()
 170   my $ext;
 171   $ext = $_[0]->{'ext'};
 172   $ext = $main::Man{'EXT'} unless $ext;
 173   $ext = '' unless defined $ext;
 174
 175   $main::Manspec = "$name.$sec,$ext";
 176   my @m;
 177   if (exists $main::Man{'MANSPEC'}{$main::Manspec}) {
 178     return 1;
 179   } else {
 180     foreach my $p ( @{$main::Man{'PATH'}} ) {
 181       foreach my $s (split //, $sec) {
 182         my $dir = File::Spec->catdir($p, "man$s");
 183         next unless -d $dir;
 184         my $file = File::Spec->catfile($dir, "$name.$s$ext");
 185         push @m, glob("$file*");
 186       }
 187     }
 188     $main::Man{'MANSPEC'}{$main::Manspec} = \@m;
 189   }
 190   return 0 unless (@m);
 191   return 1;
 192 } # is_man()
 193
 194
 195 ##########
 196 # man_get (<man_sec_ext-hash-ref>)
 197 #
 198 # Write a man page to the temporary file.
 199 #
 200 # Globals in: $main::Manspec, $main::Man{MANSPEC}, $main::Man{SEC_CHARS},
 201 #             $main::Man{EXT}, $main::Man{ALL}
 202 #
 203 # Arguments: 1, a hash reference with keys 'name', 'sec', 'ext', where
 204 #               'sec' is a string of one or several section characters
 205 #
 206 sub man_get {
 207   my $n = @_;
 208   die "man_get(): one argument is needed, you used $n;"
 209     unless $n == 1;
 210   die "man_get(): the argument is not a hash reference '$_[0]';"
 211     if ref($_[0]) ne 'HASH';
 212   die "man_get(): is_man() must be run first on the argument;"
 213     unless $main::Manspec;
 214   die "man_get(): wrong hash reference '$_[0]', no 'name' key;"
 215     unless exists $_[0]->{'name'};
 216
 217   my ($name, $sec, $ext, $f, $path);
 218   $name = $_[0]->{'name'};
 219   die "man_get(): empty 'name' key in the argument;" unless $name;
 220
 221   $sec = $_[0]->{'sec'};
 222   $sec = $main::Man{'SEC_CHARS'} if (! $sec) and $main::Man{'SEC_CHARS'};
 223   $sec = '' unless defined $sec;
 224   # take care $sec may be several sections
 225
 226 ### man_get()
 227   $ext = $_[0]->{'ext'};
 228   $ext = $main::Man{'EXT'} unless $ext;
 229   $ext = '' unless defined $ext;
 230
 231   die 'man_get(): $main::Manspec does not suit the arguments;'
 232     if ($main::Manspec ne "$name.$sec,$ext") and
 233       (! exists $main::Man{'MANSPEC'}{$main::Manspec});
 234
 235   if ($main::Man{'ALL'}) {
 236     my $ok;
 237     my %list;
 238     foreach ( @{$main::Man{'MANSPEC'}{$main::Manspec}} ) {
 239       next if exists $list{$_};
 240       if (-f $_ and -r $_) {
 241         $list{$_} = 1;
 242         &to_tmp($_);
 243         $ok = 1;
 244       }
 245     }
 246     &register_title("man:$name") if $ok;
 247     return 1;
 248   }
 249
 250   # not $main::Man{'ALL'}
 251
 252   if ($_[0]->{'sec'}) {
 253     my $path = File::Spec->catfile('', "man$sec", $name);
 254     if ($ext) {
 255       foreach $f ( @{$main::Man{'MANSPEC'}{$main::Manspec}} ) {
 256         if ($f =~ m#$path\.$sec$ext($|\..*$)#) {
 257           if (-f $f && -r $f) {
 258             &register_file($f);
 259             return 1;
 260           }
 261         }                       # if $f =~
 262       }                         # foreach $f
 263 ### man_get()
 264       foreach $f ( @{$main::Man{'MANSPEC'}{$main::Manspec}} ) {
 265         if ($f =~ m#$path\.$sec$ext.*$#) {
 266           if (-f $f && -r $f) {
 267             &register_file($f);
 268             return 1;
 269           }
 270         }                       # if $f =~
 271       }                         # foreach $f
 272     } else {                    # $ext is empty
 273       foreach $f ( @{$main::Man{'MANSPEC'}{$main::Manspec}} ) {
 274         if ($f =~ m#$path\.$sec($|\..*$)#) {
 275           if (-f $f && -r $f) {
 276             #       &to_tmp($f) && &register_file($f);
 277             &register_file($f);
 278             return 1;
 279           }
 280         }                       # if $f =~
 281       }                         # foreach $f
 282       foreach $f ( @{$main::Man{'MANSPEC'}{$main::Manspec}} ) {
 283         if ($f =~ m#$path\.$sec.*$#) {
 284           if (-f $f && -r $f) {
 285             #       &to_tmp($f) && &register_file($f);
 286             &register_file($f);
 287             return 1;
 288           }
 289         }                       # if $f =~
 290       }                         # foreach $f
 291     }                           # if $ext
 292 ### man_get()
 293   } else {                      # sec is empty
 294     my $m = $main::Man{'SEC_CHARS'};
 295     $m = $main::Man{'AUTO_SEC_CHARS'} unless $m;
 296     foreach my $s (split //, $m) {
 297       my $path = File::Spec->catfile('', "man$s", $name);
 298       unless ($ext) {
 299         foreach my $f ( @{$main::Man{'MANSPEC'}{$main::Manspec}} ) {
 300           if ( $f =~ m#$path\.$s($|\..*$)# ) {
 301             if (-f $f && -r $f) {
 302               #       &to_tmp($f) && &register_file($f);
 303               &register_file($f);
 304               return 1;
 305             }
 306           }                     # if $f =~
 307         }                       # foreach $f
 308       }                         # unless $ext
 309       foreach $f ( @{$main::Man{'MANSPEC'}{$main::Manspec}} ) {
 310         if ($f =~ m#$path\.$s$ext.*$#) {
 311           if (-f $f && -r $f) {
 312             #       &to_tmp($f) && &register_file($f);
 313             &register_file($f);
 314             return 1;
 315           }
 316         }                       # if $f =~
 317       }                         # foreach $f
 318     }                           # foreach $s
 319   }                             # if sec
 320
 321   1;
 322 } # man_get()
 323
 324
 325 ##########
 326 # man_setup ()
 327 #
 328 # Setup the variables in %MAN needed for man page searching.
 329 #
 330 # Globals:
 331 #   in:     %OPT, $LANG, $LC_MESSAGES, $LC_ALL,
 332 #           $MANPATH, $MANSEC, $PAGER, $SYSTEM, $MANOPT.
 333 #   out:    $main::Man{PATH}, $main::Man{LANG}, $main::Man{LANG2}, $main::Man{SYS},
 334 #           $main::Man{SEC}, $main::Man{ALL}
 335 #   in/out: $main::Man{ENABLE}
 336 #
 337 # The precedence for the variables related to 'man' is that of GNU
 338 # 'man', i.e.
 339 #
 340 # $LANG; overridden by
 341 # $LC_MESSAGES; overridden by
 342 # $LC_ALL; this has the same precedence as
 343 # $MANPATH, $MANSEC, $PAGER, $SYSTEM; overridden by
 344 # $MANOPT; overridden by
 345 # the groffer command-line options.
 346 #
 347 # $MANROFFSEQ is ignored because grog determines the preprocessors.
 348 #
 349 sub man_setup {
 350   return 1 if $main::Man{'IS_SETUP'};
 351   $main::Man{'IS_SETUP'} = 1;
 352   return 1 unless $main::Man{'ENABLE'};
 353
 354   # determine basic path for man pages
 355   my $path;
 356   if (defined $main::Opt{'MANPATH'}) {
 357     $path = $main::Opt{'MANPATH'};
 358   } elsif ($ENV{'MANPATH'}) {
 359     $path = $ENV{'MANPATH'};
 360   } elsif ( &where_is_prog('manpath') ) {
 361     $path = `manpath 2>$main::Dev_Null`;
 362   }
 363   if ($path) {
 364     chomp $path;
 365     $main::Man{'PATH'} = [split /:/, $path];
 366   } else {
 367     $main::Man{'PATH'} = [];
 368     &manpath_set_from_path();
 369   }
 370   unless ( @{$main::Man{'PATH'}} ) {
 371     $main::Man{'ENABLE'} = 0;
 372     warn "man_setup(): man path is empty;";
 373     return 1;
 374   }
 375
 376 ### man_setup()
 377   # make man path list consisting of unique existing directories
 378   @{$main::Man{'PATH'}} = &path_uniq( @{$main::Man{'PATH'}} );
 379
 380   unless ($main::Man{'ALL'}) {
 381     $main::Man{'ALL'} = $main::Opt{'ALL'} ? 1 : 0;
 382   }
 383
 384   # handle man systems
 385   my $sys = $ENV{'SYSTEM'};
 386   $sys = $main::Opt{'SYSTEMS'} if $main::Opt{'SYSTEMS'};
 387   if ($sys) {
 388     chomp $sys;
 389     $main::Man{'SYS'} = [split /,/, $sys];
 390   } else {
 391     $main::Man{'SYS'} = [];
 392     $sys = '';
 393   }
 394
 395 ### man_setup()
 396   # handle language
 397   my $lang = '';
 398   $lang = $main::Opt{'LANG'} if $main::Opt{'LANG'};
 399   unless ($lang) {
 400     foreach ('LC_ALL', 'LC_MESSAGES', 'LANG') {
 401       if ($ENV{$_}) {
 402         $lang = $ENV{$_};
 403         last;
 404       }
 405     }
 406   }
 407   if ($lang) {
 408     if ($lang eq 'C' or $lang eq 'POSIX') {
 409       $main::Man{'LANG'} = '';
 410       $main::Man{'LANG2'} = '';
 411     } elsif ($lang =~ /^.$/) {
 412       $main::Man{'LANG'} = $lang;
 413       $main::Man{'LANG2'} = '';
 414     } elsif ($lang =~ /^..$/) {
 415       $main::Man{'LANG'} = $lang;
 416       $main::Man{'LANG2'} = $lang;
 417     } else {
 418       $main::Man{'LANG'} = $lang;
 419       $main::Man{'LANG2'} = $lang;
 420       $main::Man{'LANG2'} =~ s/^(..).*$/$1/;
 421     }
 422   }                             # if ($lang)
 423   # from now on, use only $main::Man{LANG*},
 424   # forget about $main::Opt{LANG}, $ENV{LC_*}.
 425
 426   &manpath_add_lang_sys();
 427
 428 ### man_setup()
 429   # section
 430   my $sec;
 431   $sec = $main::Opt{'SECTIONS'} if $main::Opt{'SECTIONS'};
 432   unless ($sec) {
 433     $sec = $ENV{'MANSEC'} if $ENV{'MANSEC'};
 434   }
 435   $main::Man{'SEC'} = [];
 436   $main::Man{'SEC_CHARS'} = '';
 437   if ($sec) {
 438     foreach (split /:/, $sec) {
 439       push @{$main::Man{'SEC'}}, $_ if /^[$main::Man{'AUTO_SEC_CHARS'}]$/;
 440     }
 441     $main::Man{'SEC_CHARS'} = join '', @{$main::Man{'SEC'}} if @{$main::Man{'SEC'}};
 442   }                             # if ($sec)
 443
 444   # extension
 445   my $ext = '';
 446   $ext = $main::Opt{'EXTENSION'} if $main::Opt{'EXTENSION'};
 447   unless ($ext) {
 448     $ext = $ENV{'EXTENSION'} if $ENV{'EXTENSION'};
 449   }
 450   $main::Man{'EXT'} = $ext;
 451
 452   # creation of man temporary is omitted, because of globs in perl
 453   1;
 454 } # man_setup()
 455
 456
 457 ##########
 458 # manpath_add_lang_sys()
 459 #
 460 # Add language and operating system specific directories to man path.
 461 #
 462 # Globals:
 463 #   in:     $main::Man{SYS}: a list of names of operating systems.
 464 #           $main::Man{LANG} and $main::Man{LANG2}: each a single name
 465 #   in/out: @{$main::Man{PATH}}: list of directories which shall have the 'man?'
 466 #           subdirectories.
 467 #
 468 sub manpath_add_lang_sys {
 469   return 1 unless $main::Man{'PATH'};
 470   return 1 unless @{$main::Man{'PATH'}};
 471
 472   my @mp;
 473
 474   if ( @{$main::Man{'SYS'}} ) {
 475     foreach ( @{$main::Man{'SYS'}} ) {
 476       if ($_ eq 'man') {
 477         @mp = (@mp, @{$main::Man{'PATH'}});
 478       } elsif ($_) {
 479         my $sys = $_;
 480         foreach my $p (@{$main::Man{'PATH'}}) {
 481           my $dir = File::Spec->catdir($p, $sys);
 482           push @mp, $dir;
 483         }
 484       }                         # if eq 'man'
 485     }                           # foreach SYS
 486   } else {                      # no SYS
 487     @mp = @{$main::Man{'PATH'}};
 488   }
 489
 490   if (@mp && $main::Man{'LANG'}) {
 491     my @lang_path;
 492     my $man_lang2 = '';
 493     $man_lang2 = $main::Man{'LANG2'} if $main::Man{'LANG'} ne $main::Man{'LANG2'};
 494     foreach my $i ($main::Man{'LANG'}, $man_lang2) {
 495       next unless $i;
 496       my $lang = $i;
 497       foreach my $p (@mp) {
 498         my $dir = File::Spec->catdir($p, $lang);
 499         push @lang_path, $dir;
 500       }                         # foreach $p
 501     }                           # foreach $i
 502     @mp = (@lang_path, @mp);
 503   }                             # if $mp
 504
 505   $main::Man{PATH} = [&path_uniq(@mp)];
 506   1;
 507 } # manpath_add_lang_sys()
 508
 509
 510 ##########
 511 # manpath_set_from_path()
 512 #
 513 # Determine basic search path for man pages from $PATH.
 514 #
 515 # Return:    '1' if a valid man path was retrieved.
 516 # Output:    none
 517 # Globals:
 518 #   in:  $PATH
 519 #   out: $_MAN_PATH
 520 #
 521 sub manpath_set_from_path {
 522   my @path =
 523     qw( /usr/local /usr /usr/X11R6 /usr/openwin /opt /opt/gnome /opt/kde );
 524   # get a basic man path from $ENV{PATH}
 525   my @path2 = @main::Path;
 526   foreach (@path2) {
 527     s#bin/*$##;
 528     push @path, $_;
 529   }
 530   @path = &path_uniq(@path);
 531   foreach my $d (@path) {
 532     foreach my $e ( File::Spec->catdir( qw(share man) ),
 533                  File::Spec->catdir( qw(share MAN) ),
 534                  'man',  'MAN' ) {
 535       my $dir = File::Spec->catdir($d, $e);
 536       push @{$main::Man{'PATH'}}, $dir if -d $dir;
 537     }
 538   }
 539   1;
 540 } # manpath_set_from_path()
 541
 542
 543 ##########
 544 # special_filespec()
 545 #
 546 # Handle special modes like whatis and apropos.  Run their filespec
 547 # functions if suitable.
 548 #
 549 # Globals:  in: $main::Opt{'APROPOS'}, $main::Opt{'WHATIS'}, $main::Special_Setup
 550 #          out: $main::Special_Filespec (internal)
 551 #
 552 sub special_filespec {
 553   return 0 unless $main::Opt{'APROPOS'} || $main::Opt{'WHATIS'};
 554   die 'special_filespec(): setup for apropos or whatis must be run first;'
 555     unless $main::Special_Setup;
 556   if ( $main::Opt{'APROPOS'} ) {
 557     die "special_setup(): both apropos and whatis option variables are set;"
 558       if $main::Opt{'WHATIS'};
 559     return &apropos_filespec() ? 1 : 0;
 560   }
 561   if ( $main::Opt{'WHATIS'} ) {
 562     return &whatis_filespec() ? 1 : 0;
 563   }
 564   0;
 565 } # special_filespec
 566
 567
 568 ##########
 569 # special_setup()
 570 #
 571 # Handle special modes like whatis and apropos.  Run their setup
 572 # functions if suitable.
 573 #
 574 sub special_setup {
 575   if ( $main::Opt{'APROPOS'} ) {
 576     die "special_setup(): both --apropos and --whatis option variables " .
 577       "are set;" if $main::Opt{'WHATIS'};
 578     return &apropos_setup() ? 1 : 0;
 579   }
 580   if ( $main::Opt{'WHATIS'} ) {
 581     return &whatis_setup() ? 1 : 0;
 582   }
 583   0;
 584 } # special_setup()
 585
 586
 587 ##########
 588 # whatis_filename(<filename>)
 589 #
 590 # Interpret <filename> as a man page and display its 'whatis'
 591 # information as a fragment written in the groff language.
 592 #
 593 # Globals:  in: $main::Opt{'WHATIS'}, $main::Special_Setup, $main::Special_Filespec,
 594 #               $main::Filespec_Arg
 595 #
 596 sub whatis_filename {
 597   my $n = @_;
 598   die "whatis_filename(): one argument is needed; you used $n;"
 599     unless $n == 1;
 600   die "whatis_filename(): whatis is not setup;" unless $main::Opt{'WHATIS'};
 601   die "whatis_filename(): setup for whatis must be run first;"
 602     unless $main::Special_Setup;
 603   die "whatis_filename(): whatis_filespec() must be run first;"
 604     unless $main::Special_Filespec;
 605   die 'whatis_filename(): no $main::Filespec_Arg is set;'
 606     unless defined $main::Filespec_Arg;
 607
 608   my $arg = $_[0];
 609   die "whatis_file_name(): $arg is not an existing file" unless -f $arg;
 610   die "whatis_file_name(): could not read file $arg" unless -r $arg;
 611   return 1 if -z $arg;
 612   $arg = 'stdin' if $main::Filespec_Arg eq '-';
 613
 614   &to_tmp_line('.br', '\\f[CR]' . $arg . '\\f[]:', '.br');
 615
 616 ### whatis_filename()
 617   # get the parts of the file name according to the naming of man pages
 618   my ($dir, $name) = &split_path( $_[0] );
 619   my $section = $_[0];
 620   my $path = File::Spec->catfile('', 'man');
 621   $section =~ s#^.*$path([$main::Man{'AUTO_SEC_CHARS'}]).*$#$1#;
 622   $section = '' if $section eq $_[0];
 623   if ($section) {
 624     if ($name =~ m#^.*\.$section.*$#) {
 625       $name =~ s/^(.*)\.$section.*$/$1/;
 626     } else {
 627       $section = '';
 628     }
 629   }
 630
 631   # traditional man style; grep the line containing '.TH' macro, if any
 632   my @catz = &cat_z($_[0]);
 633   my $res;
 634   my $test;
 635   foreach (@catz) {
 636     if (/^[\.']\s*TH\s/) {              # search .TH, traditional man style
 637       $test = 1;
 638       last;
 639     }
 640   }                             # foreach (@catz)
 641 ### whatis_filename()
 642   if ($test) {                  # traditional man style
 643     # get the first line after the first '.SH' macro before the next '.SH'
 644     my $test1;
 645     foreach (@catz) {
 646       if ($test1) {
 647         chomp;
 648         next unless $_;
 649         next if /^[\.']?\s*$/;
 650         last if /^[\.']/;               # especially for .SH
 651         if ($res) {
 652           $res = "$res $_";
 653         } else {
 654           $res = $_;
 655         }
 656       } else {                  # $test1 is empty
 657         $test1 = 1 if (/^[\.']\s*SH\s/);
 658       }                         # if ($test1)
 659     }                           # foreach (@catz)
 660
 661     if ($section) {
 662       if ($res =~ m|^
 663                     $name
 664                     \s
 665                     [^-]*
 666                     -
 667                     \s*
 668                     (.*)
 669                     $|sx) {
 670         $res = "$name ($section) \\[em] $1";
 671       }
 672     }                           # if ($section)
 673 ### whatis_filename()
 674     &to_tmp_line($res, '.br', '', '.br');
 675     return 1;
 676   }                             # if ($test)
 677
 678   # mdoc style (BSD doc); grep the line containing '.Nd' macro, if any
 679   foreach (@catz) {
 680     if (/^[\.']\s*Nd\s/) {              # BSD doc style
 681       $res =~ s/^(.*)$/$name ($section) \\[em] $1/;
 682       &to_tmp_line($res);
 683       return 1;
 684     }
 685   }
 686
 687   &to_tmp_line('is not a man page', '.br', '', '.br');
 688   1;
 689 } # whatis_filename()
 690
 691
 692 ##########
 693 # whatis_filespec()
 694 #
 695 # Print the filespec name as .SH to the temporary cat file.
 696 #
 697 # Globals: in: $main::Opt{'WHATIS'}, $main::Filespec_Arg
 698 #      in/out: $main::Special_Filespec
 699 #
 700 sub whatis_filespec {
 701   return 0 unless ($main::Opt{'WHATIS'});
 702   die 'whatis_filespec(): whatis_setup() must be run first.'
 703     unless $main::Special_Setup;
 704   die 'whatis_filespec(): no $main::Filespec_Arg is set;'
 705     unless defined $main::Filespec_Arg;
 706   $main::Special_Filespec = 1;
 707   my $arg = $main::Filespec_Arg;
 708   $arg =~ s/[^\\]-/\\-/g;
 709   to_tmp_line(".SH $arg");
 710 } # whatis_filespec()
 711
 712
 713 ##########
 714 # whatis_setup ()
 715 #
 716 # Print the whatis header to the temporary cat file; this is the setup
 717 # for whatis.
 718 #
 719 # Globals:  in: $main::Opt{'WHATIS'}
 720 #          out: $main::Special_Setup
 721 sub whatis_setup {
 722   if ( $main::Opt{'WHATIS'} ) {
 723     &to_tmp_line('.TH GROFFER WHATIS');
 724     $main::Special_Setup = 1;
 725     $main::Opt{'TITLE'} = 'whatis' unless $main::Opt{'TITLE'};
 726     return 1;
 727   }
 728   0;
 729 } # whatis_setup ()
 730
 731 1;
 732 ########################################################################
 733 ### Emacs settings
 734 # Local Variables:
 735 # mode: CPerl
 736 # End: