home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-convex / man-selfload < prev    next >
Encoding:
Text File  |  1992-02-12  |  48.1 KB  |  1,830 lines
  1. #!/usr/local/bin/perl
  2. #
  3. # auto-generated by /mnt/tchrist/src/scripts/plum/tools/pb on Fri Feb 14 11:57:47 CST 1992
  4. #
  5. #!/usr/bin/perl 
  6. # 
  7. # man - perl rewrite of man system
  8. # tom christiansen <tchrist@convex.com>
  9. #
  10. # Copyright 1990 Convex Computer Corporation.
  11. # All rights reserved.
  12. #
  13. # --------------------------------------------------------------------------
  14. # begin configuration section
  15. #
  16. # this should be adequate for CONVEX systems.  if you copy this script 
  17. # to non-CONVEX systems, or have a particularly outre local setup, you may
  18. # wish to alter some of the defaults.
  19. # --------------------------------------------------------------------------
  20. $PAGER = $ENV{'MANPAGER'} || $ENV{'PAGER'} || 'more';
  21. $ADDR_CACHE = 'man.funcaddresses';
  22.  
  23. # assume "less" pagers want -sf flags, all others must accept -s.
  24. # note: some less's prefer -r to -f.  you might also add -i if supported.
  25. #
  26. $is_less = $PAGER =~ /^\S*less(\s+-\S.*)?$/;
  27. $PAGER    .= $is_less ? ' -si' : ' -s';       # add -f if using "ul"
  28.  
  29. # man roots to look in; you would really rather use a separate tree than 
  30. # manl and mann!  see %SECTIONS and $MANALT if you do.
  31. $MANPATH  = &config_path;
  32.  
  33. # default section precedence
  34. $MANSECT  = $ENV{'MANSECT'} || 'ln16823457po';
  35.  
  36. # colons optional unless you have multi-char section names
  37. # note that HP systems want this:
  38. #    $MANSECT  = $ENV{'MANSECT'} || '1:1m:6:8:2:3:4:5:7';
  39.  
  40. # alternate architecture man pages in 
  41. # ${MANALT}/${machine}/man(.+)/*.\11*
  42. $MANALT = $ENV{'MANALT'} || '/usr/local/man';
  43.  
  44. # default program for -t command 
  45. $TROFF    = $ENV{'TROFF'} || 'nitroff';
  46.  
  47. $NROFF    = 'nroff';
  48. $NROFF_CAN_BOLD = 0;    # if nroff puts out bold as H\bH
  49.  
  50. # this are used if filters are needed
  51. $TBL      = 'tbl';
  52. $NTBL       = "$TBL -D";    # maybe you need -TX instead
  53. $NEQN      = 'neqn';
  54. $EQN      = 'eqn';
  55. $SED      = 'sed';
  56.  
  57. # define this if you don't have/want UL;
  58. # without ul, you probably need COL defined unless your PAGER is very smart
  59. # you also must use col instead of ul if you've any tbl'd man pages, such 
  60. # as from the X man pages or the eqnchar.7 page.
  61. $COL      = 'col';  
  62. $UL      = '';        # set to '' if you haven't got ul
  63. die 'need either $UL or $COL' unless $UL || $COL;
  64.  
  65. # need these for .Z files or dirs
  66. $COMPRESS = 'compress';
  67. $ZCAT      = 'zcat';
  68. $CAT      = 'cat';
  69.  
  70. # define COMPRESS_DIR if pages might have moved to manX.Z/page.X (like HPs)
  71. $COMPRESS_DIR = 1;
  72. # define COMPRESS_PAGE if pages might have moved to manX/page.X.Z  (better)
  73. $COMPRESS_PAGE = 1;
  74.  
  75. # Command to format man pages to be viewed on a tty or printed on a line printer
  76. $CATSET      = "$NROFF -h -man -";
  77.  
  78. $CATSET  .= " | $COL" if $COL;
  79.  
  80. # Command to typeset a man page
  81. $TYPESET  = "$TROFF -man";
  82.  
  83.  
  84. # flags: GNU likes -i, BSD doesn't; both like -h, but BSD doesn't document it
  85. # if you don't put -i here, i'll make up for it later the hard way
  86. #$EGREP = '/usr/local/bin/egrep';    
  87. #if (-x $EGREP) {
  88.     #$EGREP .= ' -i -h';
  89. #} else {
  90.     $EGREP = '/usr/bin/egrep';
  91.     unless (-x $EGREP) {
  92.     $EGREP = '';
  93.     } else {
  94.     $EGREP .= ' -h';
  95.     }
  96. #} 
  97.  
  98. # sections that have verbose aliases
  99. # if you change this, change the usage message
  100. #
  101. # if you put any of these in their own trees, comment them out and make 
  102. # a link in $MANALT so people can still say 'man local foo'; for local,
  103. #    cd $MANALT; ln -s . local
  104. # for the other trees (new, old, public) put either them or links
  105. # to them in $MANALT
  106. #
  107. %SECTIONS = (                
  108.     'local',    'l',
  109.     'new',    'n',
  110.     'old',    'o',
  111.     'public',    'p' );
  112.  
  113. # turn this on if you want linked (via ".so" or otherwise) man pages
  114. # to be found even if the thing they are linked to doesn't know it's
  115. # being linked to -- that is, its NAME section doesn't have reference
  116. # to it.  eg, if you call a man page 'gnugrep' but it's own NAME section
  117. # just calls it grep, then you need this.  usually a good idea.
  118. #
  119. $STUPID_SO    = 1;  
  120.  
  121. # --------------------------------------------------------------------------
  122. # end configuration section
  123. # --------------------------------------------------------------------------
  124.  
  125. # CONVEX RCS keeps CHeader; others may prefer Header
  126. ($bogus, $version) = split(/:\s*/,'$CHeader: man 0.41 91/10/28 13:48:01 $',2);
  127. chop($version); chop($version);
  128.  
  129. require 'getopts.pl';
  130.  
  131. $winsize = "\0" x 8;
  132. $TIOCGWINSZ = 0x40087468;
  133.  
  134. $isatty = -t STDOUT;
  135. if (ioctl(STDIN, $TIOCGWINSZ, $winsize)) {
  136.     ($rows, $cols, $xpixel, $ypixel) = unpack('S4', $winsize);
  137. } else {
  138.     ($rows, $cols) = (24, 80);
  139. }
  140.  
  141. %options = (
  142.     'man',    'T:m:P:M:S:fkltvwdguhaAiDKn',
  143.     'apropos',    'm:P:MvduaK',
  144.     'whatis',    'm:P:M:vduh',
  145.     'whereis',    'm:P:M:vduh'
  146. );
  147.  
  148. ($program = $0) =~ s,.*/,,;
  149.  
  150. $apropos = $program eq 'apropos';
  151. $whatis  = $program eq 'whatis';
  152. $whereis = $program eq 'whman';
  153. $program = 'man' unless $options{$program};
  154.  
  155. &Getopts($options = $options{$program}) || &usage;
  156.  
  157. if ($opt_u) {
  158.     &version if $opt_v;
  159.     &usage;
  160.     # not reached
  161. } 
  162.  
  163. if ($opt_v) {
  164.     &version;
  165.     exit 0;
  166. }
  167.  
  168. &usage if $#ARGV < 0;
  169.  
  170. $MANPATH = $opt_P     if $opt_P;    # backwards contemptibility
  171. $MANPATH = $opt_M     if $opt_M;
  172.  
  173. $hard_way = $opt_h    if $opt_h;
  174.  
  175. if ($opt_T) {
  176.     $opt_t = 1;
  177.     $TYPESET =~ s/$TROFF/$opt_T/;
  178.     $TROFF = $opt_T;
  179. } 
  180.  
  181. $MANPATH = "$MANALT/$opt_m"        # want different machine type (undoc)
  182.             if $machine = $opt_m;
  183.  
  184. $MANSECT = $opt_S    if $opt_S;    # prefer our own section ordering
  185.  
  186. $whatis = 1        if $opt_f;
  187. $apropos = 1        if $opt_k || $opt_K;
  188. $fromfile = 1        if $opt_l;
  189. $whereis = 1          if $opt_w;
  190. $grepman = 1        if $opt_g;    
  191. $| = $debug = 1        if $opt_d;
  192. $full_index = 1     if $opt_i;
  193. $show_all = 1        if $opt_a;
  194. $stripBS = 1        if $opt_D;
  195. $query_all = $opt_A    if $opt_A;
  196.  
  197. $roff = $opt_t ? 'troff' : 'nroff';   # for indirect function call
  198.  
  199.  
  200. # maybe they said something like 'man vax ls'
  201. if ($#ARGV > 0) {
  202.     local($machdir) = $MANALT . '/' . $ARGV[0];
  203.     if (-d $machdir) {
  204.     $MANPATH = $machdir;
  205.     $machine = shift;
  206.     } 
  207. } 
  208.  
  209. @MANPATH = split(/:/,$MANPATH);
  210.  
  211. # assign priorities to the sections he cares about
  212. # the nearer the front the higher the sorting priority
  213. $secidx = 0;
  214. $delim = ($MANSECT =~ /:/) ? ':' : ' *';
  215. for (reverse split(/$delim/, $MANSECT)) {
  216.     if ($_ eq '') {
  217.     warn "null section in $MANSECT\n";
  218.     next;
  219.     } 
  220.     $MANSECT{$_} = ++$secidx;
  221. } 
  222.  
  223. if ($whatis) {
  224.     &whatis;
  225. } elsif ($apropos) {
  226.     &apropos;
  227. } elsif ($whereis) {
  228.     &whereis;
  229. } elsif ($grepman) {
  230.     &grepman;
  231. } else {
  232.     &man;
  233. } 
  234.  
  235. exit $status;
  236.  
  237. # --------------------------------------------------------------------------
  238. # fill out @whatis array with all possible names of whatis files
  239. # --------------------------------------------------------------------------
  240.  
  241. 1;
  242.  
  243.  
  244. # BEGIN REQUIRED MODULES
  245.  
  246.  
  247. # MODULE postcompile.pl v1.3
  248.  
  249. sub postcompile {
  250.     # local($fun) = &whowasi;  # don't do that; sigh
  251.  
  252.     &fetch_function_addrs unless $fetched_function_addrs'already++;
  253.  
  254.     local($__fun__) = $__whowasi__ || &panic("dunno who i was!");
  255.     local($__addr__);
  256.  
  257.     die("No address for $__fun__") 
  258.     unless $__addr__ = $Func_Addrs{$__fun__};
  259.  
  260.     die("$__fun__ should already be loaded") 
  261.     if $__addr__ < $Data_Start;
  262.  
  263.     die("can't load $__fun__ from $__fun__ on <DATA>: $!") 
  264.     unless seek(DATA,$__fun__,0);
  265.  
  266.     print STDERR "   " x $pindent . "loading $__fun__ from $__addr__\n";
  267.  
  268.     seek(DATA,$__addr__,0);
  269.  
  270.     local($__code__,$_);
  271.  
  272.     {
  273.     # local($_);  # WOW: this doesn't help; change to __line__ for more fun.
  274.     while ($_ = <DATA>) {
  275.         $__code__ .= $_;
  276.         last if $_ =~ /^\}/;
  277.     }
  278.     }
  279.  
  280.     die "No /^sub\\s$__fun__/in code at $__addr__:\n$__code__\n" 
  281.     unless $__code__ =~ /^sub\s+$__fun__/;
  282.  
  283.     local($tmp) = substr($_stub{$__fun__}, 7*4, 4);   
  284.     substr($_stub{$__fun__}, 7*4, 4) = substr($_main{$__fun__}, 7*4, 4);
  285.     substr($_main{$__fun__}, 7*4, 4) = $tmp;
  286.  
  287.     eval $__code__;
  288.  
  289.     $@ && die(sprintf(
  290.             "code for %s (addr %07o) didn't eval: %s\n CODE:\n%s",
  291.             $__fun__, $Func_Addrs{$__fun__}, $@, $__code__
  292.         )
  293.         );
  294.     print STDERR "   " x ++$pindent ."calling new $__fun__()\n";
  295.  
  296.     if (wantarray) {
  297.     local(@val) = &$__fun__;
  298.     print STDERR "   " x --$pindent. "returning from \@$__fun__()\n";
  299.     return @val; 
  300.     } else {
  301.     local($val) = &$__fun__;
  302.     print STDERR "   " x --$pindent. "returning from \$$__fun__()\n";
  303.     return $val; 
  304.     } 
  305. }
  306.  
  307. sub fetch_function_addrs {
  308.     local($count);
  309.     local($_);
  310.     local($hischecksum, $mychecksum);
  311.     local($update);
  312.  
  313.     $Data_Start = tell(DATA);
  314.  
  315.     print STDERR "gathering functions: " 
  316.     if defined $ENV{'debug_plum'};
  317.  
  318.     seek(DATA,0,0);
  319.     { local($/); $mychecksum = unpack("%16C*", <DATA>); }
  320.  
  321.     if ((stat(DATA))[9] > (stat($ADDR_CACHE))[9]) {
  322.     print STDERR "addrcache out of date "  if defined $ENV{'debug_plum'};
  323.     $update++;
  324.     } elsif (!open(ADDRS, $ADDR_CACHE)) {
  325.     print STDERR "can't open addrcache $ADDR_CACHE: $! "  
  326.         if defined $ENV{'debug_plum'};
  327.     $update++;
  328.     } else {
  329.     ($hischecksum) = <ADDRS> =~ /^CHECKSUM (\d+)/;
  330.         if ($mychecksum != $hischecksum) {
  331.         print STDERR "checksum mismatch "  if defined $ENV{'debug_plum'};
  332.         $update++;
  333.     }
  334.     } 
  335.  
  336.     unless ($update) {
  337.     print STDERR "yippee, snagged addrcache " if defined $ENV{'debug_plum'};
  338.     split, $Func_Addrs{$_[0]} = $_[1] while <ADDRS>;
  339.     $count = $. - 1;
  340.     close ADDRS;
  341.     } else {
  342.     seek(DATA,0,0);
  343.  
  344.     for (local($told); <DATA>; $told = tell) {
  345.         next unless /^\s*sub\s+((\w+')?(\w+))/;
  346.         warn "duplicate func $1 @ $told" if defined $Func_Addrs{$1};
  347.         $Func_Addrs{$1} = $told;
  348.         $count++;
  349.     }
  350.  
  351.     unless (open(ADDRS, ">$ADDR_CACHE")) {
  352.         print STDERR "couldn't update addrcache: $! "
  353.         if defined $ENV{'debug_plum'};
  354.     }  else { 
  355.         print STDERR "updating addrcache " if defined $ENV{'debug_plum'};
  356.         local($x,$y);
  357.         print ADDRS 'CHECKSUM ', $mychecksum, "\n";
  358.         print ADDRS $x, ' ', $y, "\n" while ($x, $y) = each %Func_Addrs;
  359.         close ADDRS;
  360.     } 
  361.     }
  362.  
  363.     print STDERR "found $count functions\n" if defined $ENV{'debug_plum'};
  364.  
  365.     seek(DATA,$Data_Start,0);
  366. }
  367. # this guy makes me coredump if used to autoload
  368.  
  369. sub whowasi {
  370.     (caller(2))[3];
  371. }
  372.  
  373.  
  374. # FUNCTION STUBS FOR POSTLOADING FROM DATA SEGMENT
  375.  
  376. ;sub PLUMBER {  $__whowasi__ = "PLUMBER"; &postcompile; }
  377. ;sub append_sub_topic {  $__whowasi__ = "append_sub_topic"; &postcompile; }
  378. ;sub apropos {  $__whowasi__ = "apropos"; &postcompile; }
  379. ;sub bysection {  $__whowasi__ = "bysection"; &postcompile; }
  380. ;sub config_path {  $__whowasi__ = "config_path"; &postcompile; }
  381. ;sub fast_whatis {  $__whowasi__ = "fast_whatis"; &postcompile; }
  382. ;sub fetch {  $__whowasi__ = "fetch"; &postcompile; }
  383. ;sub find_files {  $__whowasi__ = "find_files"; &postcompile; }
  384. ;sub find_index {  $__whowasi__ = "find_index"; &postcompile; }
  385. ;sub genwhatis {  $__whowasi__ = "genwhatis"; &postcompile; }
  386. ;sub get_page {  $__whowasi__ = "get_page"; &postcompile; }
  387. ;sub get_section {  $__whowasi__ = "get_section"; &postcompile; }
  388. ;sub getidx {  $__whowasi__ = "getidx"; &postcompile; }
  389. ;sub grepman {  $__whowasi__ = "grepman"; &postcompile; }
  390. ;sub insert_filters {  $__whowasi__ = "insert_filters"; &postcompile; }
  391. ;sub load_index {  $__whowasi__ = "load_index"; &postcompile; }
  392. ;sub man {  $__whowasi__ = "man"; &postcompile; }
  393. ;sub no_entry {  $__whowasi__ = "no_entry"; &postcompile; }
  394. ;sub nroff {  $__whowasi__ = "nroff"; &postcompile; }
  395. ;sub pick_index {  $__whowasi__ = "pick_index"; &postcompile; }
  396. ;sub print {  $__whowasi__ = "print"; &postcompile; }
  397. ;sub prompt_RTN {  $__whowasi__ = "prompt_RTN"; &postcompile; }
  398. ;sub quick_fetch {  $__whowasi__ = "quick_fetch"; &postcompile; }
  399. ;sub reformat {  $__whowasi__ = "reformat"; &postcompile; }
  400. ;sub run {  $__whowasi__ = "run"; &postcompile; }
  401. ;sub run_topic {  $__whowasi__ = "run_topic"; &postcompile; }
  402. ;sub show_index {  $__whowasi__ = "show_index"; &postcompile; }
  403. ;sub slow_fetch {  $__whowasi__ = "slow_fetch"; &postcompile; }
  404. ;sub slow_whatis {  $__whowasi__ = "slow_whatis"; &postcompile; }
  405. ;sub tmp_cleanup {  $__whowasi__ = "tmp_cleanup"; &postcompile; }
  406. ;sub trimdups {  $__whowasi__ = "trimdups"; &postcompile; }
  407. ;sub troff {  $__whowasi__ = "troff"; &postcompile; }
  408. ;sub unshell {  $__whowasi__ = "unshell"; &postcompile; }
  409. ;sub usage {  $__whowasi__ = "usage"; &postcompile; }
  410. ;sub verify {  $__whowasi__ = "verify"; &postcompile; }
  411. ;sub version {  $__whowasi__ = "version"; &postcompile; }
  412. ;sub whatis {  $__whowasi__ = "whatis"; &postcompile; }
  413. ;sub whereis {  $__whowasi__ = "whereis"; &postcompile; }
  414.  
  415.  
  416. # POSTLOADED MODULE INITIALIZATION CODE
  417.  
  418. __END__
  419.  
  420. # BEYOND THIS POINT LIE FUNCTIONS WE MAY NEVER COMPILE
  421. #--------------------------------------------------------------------------
  422. # in case we die writing to the pipe
  423. # --------------------------------------------------------------------------
  424.  
  425. # MODULE PLUMBER.pl 
  426.  
  427. sub PLUMBER {
  428.     warn "unlink $tmppage\n" if $debug;
  429.     unlink $tmppage;
  430.     die "Broken pipe while reformating $manpage\n" ;
  431. } 
  432. # --------------------------------------------------------------------------
  433. # modify $command to prime the pager with the subsection they want
  434. # --------------------------------------------------------------------------
  435.  
  436. # MODULE append_sub_topic.pl 
  437.  
  438. sub append_sub_topic {
  439.     if (defined $idx_topic)  {{
  440.     local($key);
  441.     last if $idx_topic eq '0';
  442.     unless ($idx_topic) {
  443.         $idx_topic = &pick_index;
  444.         last if $idx_topic eq "\004" || $idx_topic eq '0';
  445.     }
  446.     if ($idx_topic =~ m!^/!) {
  447.         $command .= " '+$idx_topic'";
  448.         last;
  449.     }
  450.     unless ($key = &find_index($manpage, $idx_topic)) {
  451.         warn "No subsection $idx_topic for $manpage\n\n";
  452.         $idx_topic = '';
  453.         redo;
  454.     }
  455.     $key =~ s/([!-~])/$1.$1/g unless $is_less;
  456.     $command .= " '+/^[ \t]*$key'";
  457.     }}
  458. }
  459. # --------------------------------------------------------------------------
  460. # run apropos (man -k)
  461. # --------------------------------------------------------------------------
  462.  
  463. # MODULE apropos.pl 
  464.  
  465. sub apropos {
  466.     local($_, %seeking, $target, $query);
  467.     &genwhatis;  
  468.  
  469.     for (@ARGV) { s/(\W)/\\$1/g unless $opt_K; }
  470.  
  471.     if ($EGREP)  {
  472.  
  473.     # fold case on apropos args
  474.     for (@ARGV) { 
  475.         y/A-Z/a-z/; 
  476.         $seeking{$_} = 1; 
  477.     } 
  478.     $query = join('|',@ARGV);
  479.  
  480.     # need to fake a -i flag?
  481.     unless ($EGREP =~ /-\w*i/) {
  482.         local($C);
  483.         local(@pat) = split(//,$query);
  484.         for (@pat) {
  485.         ($C = $_) =~ y/a-z/A-Z/ && ($_ = '[' . $C . $_ . ']');
  486.         } 
  487.         $query = join('',@pat);
  488.     } 
  489.     if (&run("$EGREP '$query' @whatis | $PAGER")) {
  490.         %seeking = ();
  491.     } 
  492.     } else {  # use perl
  493.     local($code) = <<'EOF';
  494.     if ($isatty) {
  495.         $pid = open(PAGER, "| $PAGER");
  496.         sleep 1;
  497.         select(PAGER);
  498.     }
  499.     foreach $WHATIS (@whatis) {
  500.         unless (open WHATIS) {
  501.         warn "can't open $WHATIS: $!\n";
  502.         next;
  503.         } 
  504.         WHATIS: while (<WHATIS>) {
  505. EOF
  506.         for (@ARGV) {
  507.         if ($opt_K && split(/\|/) > 1) { # speed hack
  508.            $code .= "OPLOOP: {\n";
  509.            for (@_) { $code .= "\tlast OPLOOP if /$_/i;\n"; } 
  510.            $code .= "next WHATIS; }\n";
  511.         } else {
  512.             $code .= "    next WHATIS unless /$_/i;\n";
  513.         }
  514.         } 
  515.         $code .= <<'EOF';
  516.         print;
  517.         }
  518.         close WHATIS;
  519.     }
  520. EOF
  521.     print "$code\n" if $debug;
  522.     eval $code;
  523.     if ($@ =~ /(.*)at \(eval\) line (\d+)/) {
  524.         ($message, $line) = ($1, $2);
  525.         if ((split(/\n/,$code))[$line-1] =~ /next unless/) {
  526.         warn "EVAL ERROR: $@ $code" if $debug;
  527.         die "$0: $message\n";
  528.         } else {
  529.         die $@;
  530.         } 
  531.     } elsif ($@) {
  532.         die $@;
  533.     } 
  534.     } 
  535.     close PAGER if $isatty;
  536. }
  537. # --------------------------------------------------------------------------
  538. # order by section.  if the complete extension has a section
  539. # priority, use that.  otherwise use the first char of extension
  540. # only.  undefined priorities are lower than any defined one.
  541. # --------------------------------------------------------------------------
  542.  
  543. # MODULE bysection.pl 
  544.  
  545. sub bysection {
  546.     local ($e1, $e2, $p1, $p2, $s1, $s2);
  547.  
  548.     ($s1, $e1) = $a =~ m:.*/man([^/]+)/.*\.([^.]+)(\.Z)?$:;
  549.     ($s2, $e2) = $b =~ m:.*/man([^/]+)/.*\.([^.]+)(\.Z)?$:;
  550.  
  551.     $e1 = $s1 if $e1 !~ /^${s1}.*/;
  552.     $e2 = $s2 if $e2 !~ /^${s2}.*/;
  553.  
  554.     $p1 = $MANSECT{$e1} || $MANSECT{substr($e1,0,1)};
  555.  
  556.     $p2 = $MANSECT{$e2} || $MANSECT{substr($e2,0,1)};
  557.  
  558.     $p1 == $p2 ? $a cmp $b : $p2 <=> $p1;
  559. } 
  560. # --------------------------------------------------------------------------
  561. # dynamically determine MANPATH (if unset) according to PATH
  562. # --------------------------------------------------------------------------
  563.  
  564. # MODULE config_path.pl 
  565.  
  566. sub config_path {
  567.     local($_);        # for traversing $PATH
  568.     local(%seen);    # weed out duplicates
  569.     local(*manpath);    # eventual return values
  570.  
  571.     if (defined $ENV{'MANPATH'}) {
  572.     $manpath = $ENV{'MANPATH'};
  573.     } else {
  574.     for (split(/:/, $ENV{'PATH'})) {
  575.         next if $_ eq '.';
  576.         next if $_ eq '..';
  577.         s![^/+]*$!man! && -d && !$seen{$_}++ && push(@manpath,$_);
  578.     }
  579.     $manpath = join(':', @manpath);
  580.     } 
  581.     # $manpath;    # last expr is assign to this anyway
  582. } 
  583. # --------------------------------------------------------------------------
  584. # do whatis lookup against dbm file(s)
  585. # --------------------------------------------------------------------------
  586.  
  587. # MODULE fast_whatis.pl 
  588.  
  589. sub fast_whatis {
  590.     local($entry, $cmd, $page, $section, $desc, @entries);
  591.  
  592.     for $INDEX (@whatis) {
  593.     unless (-f "$INDEX.pag" && dbmopen(INDEX,$INDEX,0444)) {
  594.         warn "$program: No dbm file for $INDEX: $!\n" if $debug; 
  595.         #$status = 1;
  596.         if (-f $INDEX) {
  597.         local(@whatis) = ($INDEX);  # dynamic scoping obfuscation
  598.         &slow_whatis;
  599.         }
  600.         next;
  601.     } 
  602.            for $target (@ARGV) {
  603.         local($ext);
  604.         @entries = &quick_fetch($target,'INDEX');
  605.         next if $#entries < 0;
  606.         # $target =~ s/([^\w])/\\$1/g;
  607.         for $entry (@entries) {
  608.         ($cmd, $page, $section, $desc) = split(/\001/, $entry);
  609.         #  STUPID_SO is one that .so's that reference things that
  610.         #  don't know they are being referenced.  STUPID_SO may cause
  611.         #  some peculiarities.
  612.         unless ($STUPID_SO) {
  613.             next unless $cmd =~ /$target/i || $cmd =~ /\.{3}/;
  614.         }
  615.  
  616.         delete $seeking{$target};
  617.         ($ext) = $page =~ /\.([^.]*)$/;
  618.         printf("%-20s - %s\n", "$cmd ($ext)", $desc);
  619.         }
  620.     } 
  621.     dbmclose(INDEX);
  622.     } 
  623. } 
  624. # --------------------------------------------------------------------------
  625. # lookup a given key in the given man root; returns list of hits
  626. # --------------------------------------------------------------------------
  627.  
  628. # MODULE fetch.pl 
  629.  
  630. sub fetch {
  631.     local($key,$root) = @_;
  632.     local(%recursed);
  633.  
  634.     return $dbmopened{$root}
  635.     ? &quick_fetch($key,$dbm{$root})
  636.     : &slow_fetch($key,$root);
  637. }
  638. # --------------------------------------------------------------------------
  639. # what are the file names matching this target?
  640. # --------------------------------------------------------------------------
  641.  
  642. # MODULE find_files.pl 
  643.  
  644. sub find_files {
  645.     local($target) = @_;
  646.     local($root, $entry);
  647.     local(@retlist) = ();
  648.     local(@tmplist) = ();
  649.     local(@entries) = ();
  650.     local($tar_regx);
  651.     local($found) = 0;
  652.     # globals: $vars, $called_before, %dbm, $hard_way (kinda)
  653.  
  654.     $vars = 'dbm00';  # var for magic autoincrementation
  655.  
  656.     ($tar_regx = $target) =~ s/(\W)/\\$1/g;  # quote meta
  657.  
  658.     if (!$hard_way && !$called_before++) {
  659.     # generate dbm names
  660.     for $root (@MANPATH) {
  661.         $dbm{$root} = $vars++; # magic incr
  662.         $string = "dbmopen($dbm{$root},\"$root/whatis\",0444);";
  663.         unless (-f "$root/whatis.pag" && eval $string) {
  664.         if ($@) { 
  665.             chop $@;
  666.             warn "Can't eval $string: $@";
  667.         } else {
  668.             warn "No dbm file for $root/whatis: $!\n" 
  669.             if $opt_M || $opt_P || $debug;
  670.         }
  671.         #$status = 1;
  672.         next;
  673.         } 
  674.         $dbmopened{$root} = 1;
  675.     }
  676.     } 
  677.  
  678.     for $root (@MANPATH) {
  679.     local($fullname);
  680.     @tmplist = ();
  681.     if ($hard_way || !$dbmopened{$root})  {
  682.         next unless -d $root;
  683.         warn "slow fetch on $target in $root\n" if $debug;
  684.         @tmplist = &slow_fetch($target,$root);
  685.     } else {
  686.         @entries = &fetch($target,$root);
  687.         next if $#entries < 0;
  688.  
  689.         for $entry (sort @entries) {
  690.         ($cmd, $page, $section, $desc) = split(/\001/, $entry);
  691.  
  692.         # STUPID_SO is so that .so's that reference things that
  693.         # don't know they are being referenced.  STUPID_SO may
  694.         # cause peculiarities.
  695.         unless ($STUPID_SO) {
  696.             next unless $cmd =~ /$tar_regx/i || $cmd =~ /\.{3}/;
  697.         }
  698.         push(@tmplist, "$root/man$section/$page");
  699.         }
  700.     }
  701.     push(@retlist, sort bysection @tmplist);
  702.     last if $#retlist >= 0 && $hard_way;
  703.     }
  704. #    unless (@retlist || $hard_way) {
  705. #    # shameless (ab?)use of dynamic scoping
  706. #    local($hard_way) = 1;
  707. #    warn "recursing on find_files\n" if $debug;
  708. #    return &find_files($target);
  709. #    } 
  710.      return &trimdups(@retlist);
  711. } 
  712. # --------------------------------------------------------------------------
  713. # find closest match on index selection in full index
  714. # --------------------------------------------------------------------------
  715.  
  716. # MODULE find_index.pl 
  717.  
  718. sub find_index {
  719.     local($manpage, $expr) = @_;
  720.     local($_, @matches);
  721.  
  722.     &load_index($manpage);
  723.  
  724.     $expr =~ s!^/+!!;
  725.  
  726.     for (@ssindex) { 
  727.     s/^\s*\d+\s+//; 
  728.     s/\s+\d+\s*$//; 
  729.     }
  730.  
  731.     if ($expr > 0) {
  732.     return $ssindex[$expr];
  733.     } else {
  734.     $ssindex[0] = '';
  735.     if (@matches = grep (/^$expr/i, @ssindex)) {
  736.         return $matches[0];
  737.     } elsif (@matches = grep (/$expr/i, @ssindex)) {
  738.         return $matches[0];
  739.     } else {
  740.         return '';
  741.     }
  742.     } 
  743. } 
  744.  
  745. # MODULE genwhatis.pl 
  746.  
  747. sub genwhatis {
  748.     local($elt,$whatis);
  749.  
  750.     for $elt (@MANPATH) {
  751.     $whatis = "$elt/whatis";
  752.     if (-f $whatis) {
  753.         push(@whatis, $whatis);
  754.     } else {
  755.         warn "$whatis: $!\n";# if $opt_M || $opt_P; # they asked for it
  756.     } 
  757.     } 
  758.  
  759.     die "$program: No whatis databases found, please run makewhatis\n" 
  760.     if $#whatis < 0;
  761. } 
  762. # --------------------------------------------------------------------------
  763. # pick the first page matching his target and search orders
  764. # --------------------------------------------------------------------------
  765.  
  766. # MODULE get_page.pl 
  767.  
  768. sub get_page {
  769.     local($target) = @_;
  770.     local(@found, @want);
  771.  
  772.     warn "get_page: looking for $target";
  773.  
  774.     unless (@found = &find_files($target)) {
  775.     &no_entry($target);
  776.     return '';
  777.     } 
  778.  
  779.     if (!$want_section) {
  780.     @want = @found;
  781.     } else {{
  782.     local($patsect); # in case it's section 3c++ 
  783.     ($patsect = $want_section) =~ s/(\W)/\\$1/g;
  784.  
  785.     # try exact match first
  786.     last if @want = grep (/\.$patsect$/, @found);
  787.  
  788.     # otherwise how about a subsection
  789.     last if @want = grep (/\.$patsect[^.]*$/, @found);
  790.  
  791.     # maybe it's in the wrong place (mano is notorious for this)
  792.     last if @want = grep (/man$patsect[^.]*\//, @found);
  793.  
  794.     &no_entry($target);
  795.     return '';
  796.     }}
  797.  
  798.     # WOW
  799.     for (@want) { warn "get_page: verifying $_"; $_ = &verify($_) ; warn "get_page: verified $_"; }
  800.     # THIS WORKS
  801.     #for $xyzzy (@want) { warn "get_page: verifying $xyzzy"; $xyzzy = &verify($xyzzy) ; }
  802.     $found = $want[0];
  803.  
  804.     if (@want > 1 && $query_all) {
  805.     local($ans, $i);
  806.  
  807.     select(STDERR);
  808.  
  809.     print "There are ", 0+@want, 
  810.         " manual entries available for $target:\n";
  811.     for ($i = 0; $i <= $#want; $i++) {
  812.         printf "%3d\t%s\n", $i+1, $want[$i];
  813.     } 
  814.     {
  815.         print "Which section would you like? (select 0 for all) ";
  816.         ($ans = <STDIN>) ? chop($ans) : ($ans = "\004");
  817.  
  818.         exit if $ans eq "\004";
  819.         redo if $ans eq '';
  820.  
  821.         if ($ans eq '0') {
  822.         # more dynamic scope abuse
  823.         local(@ARGV) = ($target);
  824.         local($show_all) = 1;
  825.         &man;
  826.         return '';
  827.         } 
  828.         if (--$ans > $#want) {
  829.         print "But we only have ",1+$#want, " man pages!\n";
  830.         redo;
  831.         } 
  832.  
  833.         $found = $want[$ans];
  834.     }
  835.     } 
  836.  
  837.  
  838.     select(STDOUT);
  839.  
  840.     $found;
  841. }
  842. # --------------------------------------------------------------------------
  843. # find out if he wants a special section and save in $want_section
  844. # --------------------------------------------------------------------------
  845.  
  846. # MODULE get_section.pl 
  847.  
  848. sub get_section {
  849.     local($section) = $ARGV[0];
  850.  
  851.     # interpret stty(1) as 1 stty
  852.     if ($section =~ /^(\S+)\((\S*)\),?\s*$/) {
  853.     shift @ARGV;
  854.     unshift(@ARGV, $section = $2, $1);
  855.     } 
  856.  
  857.     $section =~ tr/A-Z/a-z/;
  858.  
  859.  
  860.     if (defined $SECTIONS{$section}) {
  861.     $want_section = $SECTIONS{$section};
  862.     shift @ARGV;
  863.     }  elsif (defined($MANSECT{$section}) || $section =~ /^\d\S*$/i) { 
  864.     $want_section = shift @ARGV;
  865.     } else {
  866.     return;
  867.     } 
  868.  
  869.     $want_section =~ tr/A-Z/a-z/;
  870.  
  871.     die "But what do you want from section $want_section?\n" 
  872.     if $want_section && $#ARGV < 0;
  873. }
  874. # --------------------------------------------------------------------------
  875. # create subsection index is out of date wrt source man page
  876. # --------------------------------------------------------------------------
  877.  
  878. # MODULE getidx.pl 
  879.  
  880. sub getidx {
  881.     local($manpage) = @_;
  882.     local($is_mh);
  883.     local($_, $i, %lines, %sec, $sname, @snames);
  884.     local(@retlist, $maxlen, $header, @idx , @st_man, @st_idx);
  885.     # global no_idx_file, idx_file
  886.  
  887.     ( $idx_file = $manpage ) =~ s:/man(\w+)(\.Z)?/:/idx$1/:;
  888.     $idx_file =~ s/\.Z//;
  889.  
  890.     require 'stat.pl' unless defined &Stat;
  891.  
  892.     @st_man = &Stat($manpage);
  893.     @st_idx = &Stat($idx_file);
  894.  
  895.     if ($st_man[$ST_MTIME] < $st_idx[$ST_MTIME]) {
  896.     unless (open idx_file) {
  897.         warn "$program: can't open $idx_file: $!\n";
  898.         return ();
  899.     } 
  900.     @retlist = <idx_file>;
  901.     close idx_file;
  902.     return @saveidx = @retlist;
  903.     } 
  904.  
  905.     if (!open(manpage, $manpage =~ /\.Z/ ? "$ZCAT < $manpage|" : $manpage)) {
  906.         warn "$program: can't open $manpage: $!\n";
  907.     return ();
  908.     }
  909.     warn "building section index\n" if $debug;
  910.     ($header = "Subsections in $manpage")  =~ s!/?\S*/!!;
  911.     $maxlen = length($header);
  912.     push(@snames, $sname = 'preamble');;
  913.  
  914.     # MH has these alias for sections and subsectdions
  915.     if ($is_mh = $manpage =~ m:/mh/:) {
  916.     %mh_sections = (
  917.         "NA", "NAME",
  918.         "SY", "SYNOPSIS",
  919.         "DE", "DESCRIPTION",
  920.         "Fi", "FILES",
  921.         "Pr", "PROFILE",
  922.         "Sa", "SEE ALSO",
  923.         "De", "DEFAULTS",
  924.         "Co", "CONTEXT",
  925.         "Hh", "HELPFUL HINTS",
  926.         "Hi", "HISTORY",
  927.         "Bu", "BUGS"
  928.     );
  929.     $mh_expr = join('|',keys %mh_sections);
  930.     } 
  931.  
  932.     while (<manpage>) {
  933.     if ($is_mh && /^\.($mh_expr)/) {
  934.         $sname = $mh_sections{$+};
  935.         $maxlen = length($sname) if $maxlen < length($sname); 
  936.         push(@snames,$sname);
  937.     } 
  938.     if (/^\.s[sh]\s+(.*)/i ) {
  939.         $line = $_;
  940.         $_ = $1;
  941.         s/"//g;
  942.         s/\\f([PBIR]|\(..)//g;    # kill font changes
  943.         s/\\s[+-]?\d+//g;        # kill point changes
  944.         s/\\&//g;            # and \&
  945.         s/\\\((ru|ul)/_/g;        # xlate to '_'
  946.         s/\\\((mi|hy|em)/-/g;    # xlate to '-'
  947.         s/\\\*\(..//g;         # no troff strings
  948.         s/\\//g;               # kill all remaining backslashes 
  949.         $sname = $_;
  950.         $_ = $line;
  951.         $maxlen = length($sname) if $maxlen < length($sname); 
  952.         push(@snames,$sname);
  953.     } 
  954.     $lines{$sname}++;
  955.     } 
  956.  
  957.     $mask = sprintf("%%2d   %%-%ds %%5d\n", $maxlen + 2);
  958.  
  959.     $no_idx_file = $idx_file eq $manpage || !open(idx, ">$idx_file");
  960.  
  961.     $line = sprintf(sprintf("Idx  %%-%ds Lines\n", $maxlen + 2), $header);
  962.     @retlist = ($line);
  963.  
  964.     for ($i = 1; $i <= $#snames; $i++)  {
  965.     push(@retlist, sprintf($mask, $i, $snames[$i], $lines{$snames[$i]}));
  966.     } 
  967.     if (!$no_idx_file) {
  968.     warn "storing section index in $idx_file\n" if $debug;
  969.     print idx @retlist;
  970.     close idx;
  971.     }
  972.     return @saveidx = @retlist;
  973. }
  974. # --------------------------------------------------------------------------
  975. # grep through MANPATH for a pattern
  976. # --------------------------------------------------------------------------
  977.  
  978. # MODULE grepman.pl 
  979.  
  980. sub grepman {
  981.     local($code, $_, $dir, $root, $FILE, $found);
  982.     
  983.     $code = "while (<FILE>) {\n";
  984.  
  985.     for (@ARGV) {
  986.     s#/#\\/#g;
  987.     $code .= <<EOCODE;
  988.         if (/$_/) { 
  989.         print "\$path: \$_"; 
  990.         \$found++;
  991.         next; 
  992.         }
  993. EOCODE
  994.     } 
  995.  
  996.     $code .= "}\n";
  997.  
  998.     print "grep eval code: $code" if $debug;
  999.  
  1000.     
  1001.     foreach $root ( split(/:/, $MANPATH)) {
  1002.     unless (chdir($root)) {
  1003.         warn "can't chdir to $root: $!";
  1004.         $status++;
  1005.         next;
  1006.     } 
  1007.     foreach $dir ( <man?*> ) {
  1008.         unless (chdir($dir)) {
  1009.         warn "can't chdir to $root/$dir: $!" if $debug;
  1010.         next;
  1011.         } 
  1012.         unless (opendir(DIR, '.')) {
  1013.         warn "can't opendir $root/$dir: $!" if $debug;
  1014.         next;
  1015.         } 
  1016.         foreach $FILE ( readdir(DIR) ) {
  1017.         next if $FILE eq '.' || $FILE eq '..';
  1018.         $path = "$root/$dir/$FILE";
  1019.         if ($FILE !~ /\S\.\S/ || !-f $FILE) {
  1020.             print "skipping non-man file: $path\n" if $debug;
  1021.             next;
  1022.         } 
  1023.         if ($FILE =~ /\.Z$/ || $dir =~ /\.Z$/) {
  1024.             $FILE = "$ZCAT $FILE|";
  1025.         } 
  1026.         print STDERR "grepping $path\n" if $debug;
  1027.         unless (open FILE) {
  1028.             warn "can't open $root/$dir/$FILE: $!";
  1029.             $status++;
  1030.             next;
  1031.         } 
  1032.         eval $code;
  1033.         die $@ if $@;
  1034.         } 
  1035.         unless (chdir ($root)) {
  1036.         warn "can't return to $root: $!";
  1037.         $status++;
  1038.         last;
  1039.         } 
  1040.     } 
  1041.     } 
  1042.     exit ($status || !$found);
  1043. } 
  1044. # --------------------------------------------------------------------------
  1045. # check if page needs tbl or eqn, modifying command if needed
  1046. # add known problems for PR directory if applicable
  1047. # --------------------------------------------------------------------------
  1048.  
  1049. # MODULE insert_filters.pl 
  1050.  
  1051. sub insert_filters {
  1052.     local($filters,$eqn, $tbl, $_);
  1053.     local(*PAGE);
  1054.     local($c, $PAGE) = @_;
  1055.     local($page,$sect, $prs, $prdir);
  1056.  
  1057.     ( $page = $PAGE ) =~ s/\.Z//;
  1058.     ($prdir = $page) =~ s#/[^/]*$##;
  1059.     $prdir =~ s#man([^/]*)$#pr$1#;
  1060.     $page =~ s#.*/([^/]+)$#$1#;
  1061.  
  1062.     $PAGE = "$ZCAT < $PAGE|" if $PAGE =~ /\.Z/;
  1063.  
  1064.     (open PAGE) || die ("$program: can't open $PAGE to check filters: $!\n");
  1065.     warn "open $PAGE to check for filters in $_[0]\n" if $debug;
  1066.  
  1067.     while (<PAGE>) {
  1068.     if (/^\.EQ/) {
  1069.         $_ = <PAGE>;
  1070.         $eqn = 1 unless /\.(if|nr)/;  # has eqn output not input
  1071.     } 
  1072.     if (/^\.TS/) {
  1073.         $_ = <PAGE>;
  1074.         $tbl = 1 unless /\.(if|nr)/;  # has tbl output not input
  1075.     } 
  1076.     last if $eqn && $tbl;
  1077.     } 
  1078.     close PAGE;
  1079.  
  1080.     if ($roff eq 'troff') {
  1081.     $eqn && $_[0] =~ s/(\S+roff)/$EQN | $1/;
  1082.     $tbl && $_[0] =~ s/(\S+roff)/$TBL | $1/;
  1083.     } else { # nroff
  1084.     $eqn && $_[0] =~ s/(\S+roff)/$NEQN | $1/;
  1085.     $tbl && $_[0] =~ s/(\S+roff)/$NTBL | $1/;
  1086.     }
  1087.  
  1088.     ($sect) = $page =~ /\.(\d)[^.]*$/;
  1089.     $prs = "$prdir/$page";
  1090.     if (-e $prs) {
  1091.     warn "found PRs for $page\n" if $debug;
  1092.     if ($roff eq 'nroff')  {
  1093.         $_[0] =~ s/ - / - $prs/;
  1094.     } else {
  1095.         $_[0] .= " $prs";
  1096.     } 
  1097.     } else {
  1098.     print "no PRS for $page in $prs\n" if $debug;
  1099.     } 
  1100.     $_[0];
  1101. } 
  1102. # --------------------------------------------------------------------------
  1103. # read in subsection index into @ssindex
  1104. # --------------------------------------------------------------------------
  1105.  
  1106. # MODULE load_index.pl 
  1107.  
  1108. sub load_index {
  1109.     local($manpage)  = @_;
  1110.     $no_idx_file = 0;
  1111.     &getidx($manpage) if $#saveidx < 0;
  1112.     @ssindex = @saveidx;
  1113.     die "should have have an index for $manpage" if $#saveidx < 0;
  1114. } 
  1115. # --------------------------------------------------------------------------
  1116. # run a normal man command
  1117. # --------------------------------------------------------------------------
  1118.  
  1119. # MODULE man.pl 
  1120.  
  1121. sub man {
  1122.     local($target,$page);
  1123.  
  1124.  
  1125.     while (@ARGV) {
  1126.     undef $idx_topic;
  1127.  
  1128.     &get_section;
  1129.     $target = shift @ARGV;
  1130.  
  1131.     if (!$fromfile && $target =~ m!^([^/]+)/(.*)!) {
  1132.         if (!$isatty) {
  1133.         warn "$program: no tty, so no pager to prime with index\n";
  1134.         $target = $1;
  1135.         }  else {
  1136.         ($target, $idx_topic) = ($1, $2);
  1137.         } 
  1138.     } else {
  1139.         undef $idx_topic;
  1140.     } 
  1141.  
  1142.     if ($show_all) {
  1143.         local(@pages);
  1144.         local($was_defined) = defined $idx_topic;
  1145.         @pages = &find_files($target);
  1146.         if (!@pages) {
  1147.         &no_entry($target);
  1148.         next;
  1149.         } 
  1150.         while ($tpage = shift @pages) {
  1151.         undef $idx_topic unless $was_defined;
  1152.         do $roff(&verify($tpage));
  1153.         &prompt_RTN("to read $pages[0]") 
  1154.             if $roff eq 'nroff' && @pages;
  1155.         } 
  1156.     } else {
  1157.         $target = &get_page($target) unless $fromfile;
  1158.         do $roff($target) if $target;
  1159.     }
  1160.     &prompt_RTN("to read man page for $ARGV[0]") 
  1161.         if $roff eq 'nroff' && @ARGV;
  1162.     } 
  1163. } 
  1164. # --------------------------------------------------------------------------
  1165. # whine about something not being found
  1166. # --------------------------------------------------------------------------
  1167.  
  1168. # MODULE no_entry.pl 
  1169.  
  1170. sub no_entry {
  1171.     print STDERR "No manual entry for $_[0]";
  1172.     if ($machine || $want_section) {
  1173.     print STDERR " in";
  1174.     print STDERR " section $want_section of" if $want_section;
  1175.     print STDERR " the";
  1176.     print STDERR " $machine" if $machine;
  1177.     print STDERR " manual";
  1178.     }
  1179.     print STDERR ".\n";
  1180.     $status = 1;
  1181. } 
  1182. # --------------------------------------------------------------------------
  1183. # just run a regular nroff, possibly showing the index first.
  1184. # --------------------------------------------------------------------------
  1185.  
  1186. # MODULE nroff.pl 
  1187.  
  1188. sub nroff {
  1189.     local($manpage) = $_[0];
  1190.     local($catpage);
  1191.     local($tmppage);
  1192.     local($command);
  1193.     local(@saveidx);
  1194.     local($manroot);
  1195.     local($macros);
  1196.     local($intmp);
  1197.     local(@st_cat, @st_man);
  1198.  
  1199.     die "trying to nroff a null man page" if $manpage eq '';
  1200.  
  1201.     umask 022;
  1202.  
  1203.     if ($full_index) {
  1204.     &show_index($manpage);
  1205.     return;
  1206.     } 
  1207.     if ($fromfile) {
  1208.     $command = (($manpage =~ m:\.Z/:) ? $ZCAT : $CAT)
  1209.             . " < $manpage | $CATSET";
  1210.     &insert_filters($command, $manpage);
  1211.     } else {
  1212.     require 'stat.pl' unless defined &Stat;   
  1213.     # compiled version has this already
  1214.  
  1215.  
  1216.     ($catpage = $manpage) 
  1217.         =~ s,^(.*)/man([^\.]*)(\.Z)?/([^/]*)$,$1/cat$2/$4,;
  1218.  
  1219.     $manroot = $1;
  1220.  
  1221.     # Does the cat page exist?
  1222.     if (! -f $catpage && $COMPRESS_DIR){
  1223.         # No, maybe it is compressed?
  1224.         if (-f "$1/cat$2.Z/$4"){
  1225.         # Yes it was.
  1226.         $catpage = "$1/cat$2.Z/$4";
  1227.         } else {
  1228.         # Nope, the cat file doesn't exist.
  1229.             # Prefer the compressed cat directory if it exists.
  1230.             $catpage = "$1/cat$2.Z/$4" 
  1231.             if $catpage !~ /\.Z$/ && -d "$1/cat$2.Z";
  1232.         }
  1233.     }
  1234.  
  1235.  
  1236.     @st_man = &Stat($manpage);
  1237.  
  1238.     if ($st_man[$ST_SIZE] == 0) {
  1239.         warn "$program: $manpage is length 0!\n";
  1240.         $status = 1;
  1241.         return;
  1242.     } 
  1243.  
  1244.     @st_cat = &Stat($catpage);
  1245.  
  1246.  
  1247.     if ($st_cat[$ST_MTIME] < $st_man[$ST_MTIME]) {
  1248.  
  1249.         $command = (($manpage =~ m:\.Z:) ? $ZCAT : $CAT)
  1250.             . " < $manpage | $CATSET";
  1251.  
  1252.         $command = &insert_filters($command, $manpage);
  1253.         $command =~ s,-man,$manroot/tmac.an, if -e "$manroot/tmac.an";
  1254.  
  1255.         ($catdir = $catpage) =~ s!^(.*/?cat[^/]+)/[^/]*!$1!;
  1256.  
  1257.         chdir $manroot;
  1258.  
  1259.         $tmppage = "$catpage.$$";
  1260.  
  1261.         unless (-d $catdir && -w _ 
  1262.             && open(tmppage, ">$tmppage") # usually EROFS
  1263.             && close(tmppage) )
  1264.         {
  1265.         $catpage = $tmppage = "/tmp/man.$$";
  1266.         $intmp = 1;
  1267.         }
  1268.  
  1269.         printf STDERR "Reformatting page.  Please wait ... " if $isatty;
  1270.  
  1271.         $command .= "| $COMPRESS" if $catpage =~ /\.Z/;
  1272.         $command .= "> $tmppage";
  1273.  
  1274.         $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'HUP'} = $SIG{'TERM'}  
  1275.         = 'tmp_cleanup';
  1276.  
  1277.         $SIG{'PIPE'} = 'PLUMBER';
  1278.  
  1279. REFORMAT:   { unless (&reformat($command)) {
  1280.         warn "$program: nroff of $manpage into $tmppage failed\n"
  1281.             unless $@;
  1282.         unlink $tmppage unless $debug;
  1283.         if (!$intmp++) {
  1284.             $catpage = $tmppage = "/tmp/man.$$";
  1285.             warn "$program: hang on... retrying into $tmppage\n";
  1286.             $command =~ s/> \S+$/> $tmppage/;
  1287.             $status = 0;
  1288.             redo REFORMAT;
  1289.         } else {
  1290.             #$status = 1;
  1291.             return;
  1292.         }
  1293.         }} 
  1294.         warn "done\n" if $isatty;
  1295.  
  1296.         $intmp || rename($tmppage,$catpage) || 
  1297.         die "couldn't rename $tmppage to $catpage: $!\n";
  1298.         
  1299.         $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'HUP'} = $SIG{'TERM'} =
  1300.         $SIG{'PIPE'} = 'DEFAULT';
  1301.  
  1302.     } 
  1303.     $command = (($catpage =~ m:\.Z:)
  1304.             ? $ZCAT
  1305.             : $CAT)
  1306.             . " < $catpage";
  1307.     }
  1308.     if (-z $catpage) {
  1309.     unlink $catpage;
  1310.     die "$program: $catpage was length 0; disk full?\n";
  1311.     } 
  1312.     $command .= "| $UL"         if $UL;
  1313.     $command .= "| $SED 's/.\b//g'"     if $stripBS;
  1314.  
  1315.     if ($isatty) {  
  1316.         $command .= "| $PAGER";
  1317.         # If the pager is less, use the man page as the prompt, even if pipe
  1318.         if ($is_less) { 
  1319.             # Escape all periods because less interprets them.  We also
  1320.             # need to add an extra '\' to escape the shell intrepetation
  1321.             # of '\'.  We also need to make a copy of $manpage, because
  1322.             # the substitution trashes the string and it is needed later.
  1323.             ($lessprompt = $manpage) =~ s/\./\\./g;
  1324.         $lessprompt = "$lessprompt byte %bB?s/%s .?e(END) :?pB%pB\\%.%t"
  1325.             if $ENV{'LESS'} =~ /M/; # he wants a long prompt
  1326.             $command .= " '-MPM$lessprompt'";
  1327.         }
  1328.     }
  1329.  
  1330.     &run_topic;
  1331.     unlink($tmppage) if $intmp;
  1332. } 
  1333. # --------------------------------------------------------------------------
  1334. # present subsections and let user select one
  1335. # --------------------------------------------------------------------------
  1336.  
  1337. # MODULE pick_index.pl 
  1338.  
  1339. sub pick_index {
  1340.      local($_);
  1341.      print "Valid sections for $page follow.  Choose the section\n";
  1342.      print "index number or string pattern. (0 for full page, RTN to quit.)\n\n";
  1343.      &show_index;
  1344.      print "\nWhich section would you like? ";
  1345.      ($_ = <STDIN>) ? chop : ($_ = "\004");
  1346.      $_ = "\004" if 'quit' =~ /^$_/;
  1347.      return $_;
  1348. } 
  1349. # --------------------------------------------------------------------------
  1350. # print line with C\bC style emboldening 
  1351. # --------------------------------------------------------------------------
  1352.  
  1353. # MODULE print.pl 
  1354.  
  1355. sub print {
  1356.     local($_) = @_;
  1357.  
  1358.     if (!$inbold) {
  1359.     print;
  1360.     } else {
  1361.     local($last);
  1362.     for (split(//)) {
  1363.             if ($last eq "\033") {
  1364.                 print;
  1365.             } else {
  1366.                 print /[!-~]/ ? $_."\b".$_ : $_;
  1367.             }
  1368.             $last = $_;
  1369.     }
  1370.     } 
  1371. }
  1372. # --------------------------------------------------------------------------
  1373. # prompt for <RET> if we're a tty and have a non-stopping pager
  1374. # --------------------------------------------------------------------------
  1375.  
  1376. # MODULE prompt_RTN.pl 
  1377.  
  1378. sub prompt_RTN {
  1379.     local($why) = $_[0] || "to continue";
  1380.     return unless $isatty;
  1381.     unless ($is_less && $ENV{'LESS'} !~ /E/) {
  1382.     print "Hit <RTN> $why: ";
  1383.     $_ = <STDIN>;
  1384.     }
  1385. }
  1386. # --------------------------------------------------------------------------
  1387. # do a quick fetch of a key in the dbm file, recursing on indirect references
  1388. # --------------------------------------------------------------------------
  1389.  
  1390. # MODULE quick_fetch.pl 
  1391.  
  1392. sub quick_fetch {
  1393.     local($key,$array) = @_;
  1394.     local(@retlist) = ();
  1395.     local(@tmplist) = ();
  1396.     local($_, $entry);
  1397.     local($name, $ext);
  1398.     local(@newlist);
  1399.  
  1400.     return @retlist unless $entry = eval "\$$array".'{$key};';
  1401.  
  1402.     if ($@) { chop $@; die "bad eval: $@"; }
  1403.  
  1404.     @tmplist = split(/\002/, $entry);
  1405.     for (@tmplist) {
  1406.     if (/\001/) {
  1407.         push(@retlist, $_);
  1408.     } else {
  1409.         ($name, $ext) = /(.+)\.([^.]+)/;
  1410.         push(@retlist, 
  1411.         grep(/[^\001]+\001[^\001]+\001${ext}\001/ || /[^\001]+${ext}\001/,
  1412.             &quick_fetch($name, $array)));
  1413.     # explain and diction are near duplicate man pages referencing
  1414.     # each other, requiring the $recursed check.  one should be removed
  1415.     }
  1416.     } 
  1417.     return @retlist;
  1418. } 
  1419. # --------------------------------------------------------------------------
  1420. # reformat the page with nroff, fixing up bold escapes
  1421. # --------------------------------------------------------------------------
  1422.  
  1423. # MODULE reformat.pl 
  1424.  
  1425. sub reformat { 
  1426.     local($_) = @_; 
  1427.     local($nroff, $col); 
  1428.     local($inbold) = 0;
  1429.     local($status);
  1430.  
  1431.     if ($NROFF_CAN_BOLD) {
  1432.     return &run($_);
  1433.     } 
  1434.  
  1435.     &unshell($_);
  1436.     ($nroff, $col) = m!(.*)\|\s*($COL.*)!;
  1437.  
  1438.     if ( $opt_n ) {
  1439.     warn "$_\n";
  1440.     return 1;
  1441.     }
  1442.  
  1443.     warn "$nroff | (this proc) | $col\n" if $debug;
  1444.  
  1445.     open (NROFF, "$nroff |");
  1446.     $colpid = open (COL, "| $col");
  1447.  
  1448.     select(COL);
  1449.  
  1450.     while (<NROFF>) {
  1451.     s/\033\+/\001/;
  1452.     s/\033\,/\002/;
  1453.     if ( /^([^\001]*)\002/ || /^([^\002]*)\001/ )  {
  1454.         &print($1);
  1455.         $inbold = !$inbold;
  1456.         $_ = $';
  1457.         redo;
  1458.     }   
  1459.     &print($_);
  1460.     }
  1461.  
  1462.     close NROFF;
  1463.     if ($?) { 
  1464.     warn "$program: \"$nroff\" failed! status=$?" if $debug;
  1465.     $status++;
  1466.     } 
  1467.     close COL;
  1468.     if ($?) {
  1469.     warn "$program: \"$col\" failed! status=$?" if $debug;
  1470.     $status++;
  1471.     }
  1472.     select(STDOUT);
  1473.     $status == 0;
  1474. } 
  1475. # --------------------------------------------------------------------------
  1476. # call system on command arg, stripping of sh-isms and echoing for debugging
  1477. # --------------------------------------------------------------------------
  1478.  
  1479. # MODULE run.pl 
  1480.  
  1481. sub run {
  1482.     local($command) = $_[0];
  1483.  
  1484.     &unshell($command);
  1485.  
  1486.     if ( $opt_n ) {
  1487.     warn "$command\n";
  1488.     return 1;
  1489.     }
  1490.  
  1491.     warn "running: $command\n" if $debug;
  1492.     if (system $command) {
  1493.     $status = 1;
  1494.     printf STDERR "\"%s\" exited %d, sig %d\n", $command, 
  1495.         ($? >> 8), ($? & 255) if $debug;
  1496.     }
  1497.     return ($? == 0);
  1498. } 
  1499. # --------------------------------------------------------------------------
  1500. # see whether they want to start at a subsection, then run the command
  1501. # --------------------------------------------------------------------------
  1502.  
  1503. # MODULE run_topic.pl 
  1504.  
  1505. sub run_topic {
  1506.     local($_);
  1507.     local($menu_rtn) = defined $idx_topic && $idx_topic eq '';
  1508.     {
  1509.     &append_sub_topic;
  1510.     last if $idx_topic eq "\004";
  1511.     if ($idx_topic eq '0') {
  1512.         $menu_rtn = 0;
  1513.         $idx_topic = '';
  1514.         $command =~ s: '\+/[^']*'::;
  1515.     }
  1516.     $fromfile ? &reformat($command) : &run($command);
  1517.     if ($menu_rtn) {
  1518.         $idx_topic = '';
  1519.         &prompt_RTN("to return to the index");
  1520.         $command =~ s! '\+/.*$!!;
  1521.         redo;
  1522.     } 
  1523.     }
  1524.     
  1525. } 
  1526. # --------------------------------------------------------------------------
  1527. # create and display subsection index via pager
  1528. # --------------------------------------------------------------------------
  1529.  
  1530. # MODULE show_index.pl 
  1531.  
  1532. sub show_index {
  1533.     local($_);
  1534.     &load_index($_[0]);
  1535.     if ($#ssindex > ($rows - 4) && $isatty) {
  1536.     print "Hit <RTN> for $#ssindex subsections via pager: ";
  1537.     $_ = <STDIN>;
  1538.     if ($no_idx_file) {
  1539.         open (PAGER, "| $PAGER");
  1540.         print PAGER @ssindex;
  1541.         close PAGER;
  1542.     } else {
  1543.         &run("$PAGER $idx_file");
  1544.     } 
  1545.     } else {
  1546.     print STDOUT @ssindex;
  1547.     }
  1548. } 
  1549. # --------------------------------------------------------------------------
  1550. # do a slow fetch for target using perl's globbing notation
  1551. # --------------------------------------------------------------------------
  1552.  
  1553. # MODULE slow_fetch.pl 
  1554.  
  1555. sub slow_fetch {
  1556.     local($target,$root) = @_;
  1557.     local($glob, $stem, $entry);
  1558.  
  1559.     $target =~ s/(\W)/\\$1/g;  # for str$round(3V) or /bin/[
  1560.  
  1561.     if ($want_section) {
  1562.     if ($MANSECT{$want_section}) {
  1563.         $stem = $want_section;
  1564.     } else {
  1565.         $stem = substr($want_section,0,1);
  1566.         } 
  1567.     $glob = "man$stem*";
  1568.     } else {
  1569.     $glob = 'man*';
  1570.     } 
  1571.     $glob = "$root/$glob/$target.*";
  1572.     return <${glob}>;
  1573. }
  1574. # --------------------------------------------------------------------------
  1575. # do whatis lookup the hard way
  1576. # --------------------------------------------------------------------------
  1577.  
  1578. # MODULE slow_whatis.pl 
  1579.  
  1580. sub slow_whatis {
  1581.     local($query);
  1582.     local($WHATIS);
  1583.  
  1584.     for (@ARGV) { s/([^\w])/\\$1/g; } 
  1585.  
  1586.     $query = '^[^-]*\b?(' . join('|',@ARGV) . ')\b[^-]* -';
  1587.  
  1588.     if ($EGREP)  {
  1589.     if (&run("$EGREP '$query' @whatis")) {
  1590.         # pity can't tell which i found
  1591.         %seeking = ();
  1592.     }
  1593.     } else {
  1594.     foreach $WHATIS (@whatis)  {
  1595.         unless (open WHATIS) {
  1596.         warn "can't open $WHATIS: $!\n";
  1597.         next;
  1598.         } 
  1599.         while (<WHATIS>) {
  1600.         next unless /$query/i;
  1601.         ($target = $+) =~ y/A-Z/a-z/;
  1602.         delete $seeking{$target};
  1603.         print;
  1604.         } 
  1605.         close WHATIS;
  1606.     } 
  1607.     } 
  1608. } 
  1609. # --------------------------------------------------------------------------
  1610. # interrupted -- unlink temp page
  1611. # --------------------------------------------------------------------------
  1612.  
  1613. # MODULE tmp_cleanup.pl 
  1614.  
  1615. sub tmp_cleanup {
  1616.     warn "unlink $tmppage\n" if $debug;
  1617.     unlink $tmppage;
  1618.     die "Interrupted!\n";
  1619. } 
  1620. # --------------------------------------------------------------------------
  1621. # due to aliasing the dbase sometimes has the same thing twice
  1622. # --------------------------------------------------------------------------
  1623.  
  1624. # MODULE trimdups.pl 
  1625.  
  1626. sub trimdups {
  1627.     local(%seen) = ();
  1628.     local(@retlist) = ();
  1629.  
  1630.     while ($file = shift) {
  1631.     push(@retlist,$file) unless $seen{$file}++;
  1632.     } 
  1633.     return @retlist;
  1634. } 
  1635. # --------------------------------------------------------------------------
  1636. # run through the typesetter
  1637. # --------------------------------------------------------------------------
  1638.  
  1639. # MODULE troff.pl 
  1640.  
  1641. sub troff {
  1642.     local ($file) = $_[0];
  1643.     local ($command);
  1644.     local ($manroot);
  1645.     local ($macros);
  1646.  
  1647.     ($manroot) = $file =~ m,^(.*)/man([^\.]*)(\.Z)?/([^/]*),;
  1648.  
  1649.     $command = ((($file =~ m:\.Z:) 
  1650.             ? $ZCAT 
  1651.             : $CAT) 
  1652.         . " < $file | $TYPESET");
  1653.  
  1654.     $command =~ s,-man,$manroot/tmac.an, if -e "$manroot/tmac.an";
  1655.  
  1656.     &insert_filters($command,$file);
  1657.     &run($command);
  1658. } 
  1659. # --------------------------------------------------------------------------
  1660. # strip arg of extraneous cats and redirects    
  1661. # --------------------------------------------------------------------------
  1662.  
  1663. # MODULE unshell.pl 
  1664.  
  1665. sub unshell {
  1666.     $_[0] =~ s/^\s*cat\s*<?\s*([^\s|]+)\s*\|\s*([^|]+)/$2 < $1/;
  1667.     $_[0] =~ s/^([^|<]+)<([^Z|<]+)$/$1 $2/;
  1668.     ($roff eq 'troff') && $_[0] =~ s#(/usr/man/pr\S+)\s+(\S+)#$2 $1#;
  1669. }
  1670. # --------------------------------------------------------------------------
  1671. # print out usage message via pager and exit
  1672. # --------------------------------------------------------------------------
  1673.  
  1674. # MODULE usage.pl 
  1675.  
  1676. sub usage {
  1677.     unless ($opt_u) {
  1678.     warn "usage: $program [-flags] topic ...\n";
  1679.     warn "        (use -u for long usage message)\n";
  1680.     } else {
  1681.     open (PIPE, "| $PAGER");
  1682.     print PIPE <<USAGE;  # in case he wants a page
  1683. USAGE SUMMARY: 
  1684.     man [-flags] [section] page[/index] ...
  1685.     (section is [1-8lnop], or "new", "local", "public", "old")
  1686.     (index is section or subsection header)
  1687.  
  1688.     man [-flags] -f topic ...  
  1689.     (aka "whatis")
  1690.  
  1691.     man [-flags] -k keyword ...
  1692.     (aka "apropos")
  1693.  
  1694. FLAGS: (most only make sense when invoked as 'man')
  1695.     -a        show all possible man pages for this topic
  1696.     -A        ask which selection if several available
  1697.  
  1698.     -l file    do man processing on local file
  1699.     -f topic    list table of contents entry for topic
  1700.     -k keyword    give table of contents entries containing keyword
  1701.     -K pattern  as -K but allow regexps
  1702.     -g pattern  grep through all man pages for patterns
  1703.     -w topic    which files would be shown for a given topic
  1704.     -i topic    show section and subsection index for use with topic/index
  1705.  
  1706.     -M path    use colon-delimited man path for searching (also as -P)
  1707.     -S sects    define new section precedence 
  1708.  
  1709.     -t        troff the man page
  1710.     -T path    call alternate typesetter on the man page
  1711.  
  1712.     -d        print out all system() commands before running them
  1713.     -h        do all lookups the hard way, ignoring any DBM files
  1714.     -u        this message
  1715.     -v        print version string
  1716.     -D        strip backspaces from output
  1717.  
  1718. ENVIRONMENT:
  1719.     \$PAGER    pager to pipe terminal-destined output through 
  1720.     \$MANPATH    like -M path
  1721.     \$MANSECT    like -S sects
  1722.     \$MANALT    used for alternate hardware types (or obsolete -m flag)
  1723.     \$TROFF    like -T path
  1724.  
  1725. CURRENT DEFAULTS:
  1726.     PAGER    $PAGER
  1727.     MANPATH    $MANPATH
  1728.     MANSECT    $MANSECT
  1729.     MANALT    $MANALT
  1730.     TROFF    $TROFF
  1731.  
  1732. NOTES:  (\$manroot is each component in \$MANPATH)
  1733.     * If \$manroot/whatis DBM files do not exist, a warning will be 
  1734.     printed (if -d flag) and -h will be assumed for that \$manroot only.
  1735.     * If \$manroot/tmac.an exists, it will be used for formatting 
  1736.     instead of the normal -man macros.
  1737.     * Man pages may be compressed either in (for example) man1.Z/who.1 
  1738.         or man1/who.1.Z; cat pages will go into corresponding places.
  1739.     * If the man page contains .EQ or .TS directives, eqn and/or tbl
  1740.         will be invoked as needed at format time.
  1741. USAGE
  1742.     close PIPE;
  1743.     }
  1744.     warn "couldn't run long usage message thru $PAGER?!?!\n" if $?;
  1745.     exit 1;
  1746. }
  1747. # --------------------------------------------------------------------------
  1748. # figure out full path name of man page, which may have been compressed
  1749. # --------------------------------------------------------------------------
  1750.  
  1751. # MODULE verify.pl 
  1752.  
  1753. sub verify {
  1754.     local($path) = @_;
  1755.     local($orig) = $path;
  1756.  
  1757.     warn "verify: verifying $path";
  1758.  
  1759.     return $path if -f $path;
  1760.  
  1761.     if ($COMPRESS_PAGE) {
  1762.     $path .= '.Z';
  1763.     return $path if -f $path;
  1764.     $path =~ s/.Z//;
  1765.     } 
  1766.  
  1767.     if ($COMPRESS_DIR) {
  1768.     $path =~ s-(/[^/]*)$-.Z$1-;
  1769.     return $path if -f $path;
  1770.     } 
  1771.  
  1772.     warn "$program: $orig has disappeared -- rerun makewhatis\n";
  1773.     $status = 1;
  1774.     return '';
  1775. }
  1776. # --------------------------------------------------------------------------
  1777. # just print the version
  1778. # --------------------------------------------------------------------------
  1779.  
  1780. # MODULE version.pl 
  1781.  
  1782. sub version  {
  1783.     warn "$program: version is \"$version\"\n" ;
  1784. }
  1785. # --------------------------------------------------------------------------
  1786. # run whatis (man -f)
  1787. # --------------------------------------------------------------------------
  1788.  
  1789. # MODULE whatis.pl 
  1790.  
  1791. sub whatis {
  1792.     local($target, %seeking, $section, $desc, @entries);
  1793.  
  1794.     &genwhatis;
  1795.  
  1796.     for $target (@ARGV) { $seeking{$target} = 1; } 
  1797.  
  1798.     if ($hard_way) {
  1799.     &slow_whatis;
  1800.     } else { 
  1801.     &fast_whatis;
  1802.     }
  1803.  
  1804.     for $target (keys %seeking) {
  1805.     print "$program: $target: not found.\n";
  1806.     $status = 1;
  1807.     } 
  1808. } 
  1809. # --------------------------------------------------------------------------
  1810. # run 'man -w'
  1811. # --------------------------------------------------------------------------
  1812.  
  1813. # MODULE whereis.pl 
  1814.  
  1815. sub whereis {
  1816.     local($target, @files);
  1817.  
  1818.     foreach $target (@ARGV) {
  1819.     @files = &find_files($target);
  1820.     if ($#files < $[) {
  1821.         warn "$program: $target not found\n";
  1822.         $status = 1;
  1823.     } else {
  1824.         print "$target: " if $#ARGV;
  1825.         for (@files) { print &verify($_), " "; }
  1826.         print "\n";
  1827.     }
  1828.     } 
  1829. } 
  1830.