#!/usr/local/bin/perl
# 
# man - perl rewrite of man system
# tom christiansen <tchrist@perl.com>
#
# --------------------------------------------------------------------------
# begin configuration section
#
# this should be adequate for CONVEX systems.  if you copy this script 
# to non-CONVEX systems, or have a particularly outre local setup, you may
# wish to alter some of the defaults.
# --------------------------------------------------------------------------

use DB_File;
@Any_DBM_File::ISA = qw(DB_File);

$PAGER = $ENV{'MANPAGER'} || $ENV{'PAGER'} || 'more';

# assume "less" pagers want -sf flags, all others must accept -s.
# note: some less's prefer -r to -f.  you might also add -i if supported.
#
$is_less = $PAGER =~ /^\S*less(\s+-\S.*)?$/;
$PAGER    .= $is_less ? ' -si' : ' -s';       # add -f if using "ul"

# man roots to look in; you would really rather use a separate tree than 
# manl and mann!  see %SECTIONS and $MANALT if you do.
$MANPATH  = &config_path;

# default section precedence
$MANSECT  = $ENV{'MANSECT'} || 'ln16823457po';

# colons optional unless you have multi-char section names
# note that HP systems want this:
#	$MANSECT  = $ENV{'MANSECT'} || '1:1m:6:8:2:3:4:5:7';

# alternate architecture man pages in 
# ${MANALT}/${machine}/man(.+)/*.\11*
$MANALT = $ENV{'MANALT'} || '/usr/local/man';

# default program for -t command 
$TROFF    = $ENV{'TROFF'} || 'troff';

$NROFF    = 'nroff';
$NROFF_CAN_BOLD = 0;	# if nroff puts out bold as H\bH

# this are used if filters are needed
$TBL	  = 'tbl';
$NTBL 	  = "$TBL";	# maybe you need -TX instead
$NEQN	  = 'neqn';
$EQN	  = 'eqn';
$SED	  = 'sed';

# define this if you don't have/want UL;
# without ul, you probably need COL defined unless your PAGER is very smart
# you also must use col instead of ul if you've any tbl'd man pages, such 
# as from the X man pages or the eqnchar.7 page.
$COL	  = 'col';  
$UL	  = '';		# set to '' if you haven't got ul
die 'need either $UL or $COL' unless $UL || $COL;

# need these for .gz files or dirs
$COMPRESS = 'gzip';
$ZCAT	  = 'zcat';
$CAT	  = 'cat';

# define COMPRESS_DIR if pages might have moved to manX.gz/page.X (like HPs)
$COMPRESS_DIR = 1;
# define COMPRESS_PAGE if pages might have moved to manX/page.X.gz  (better)
$COMPRESS_PAGE = 1;

# Command to format man pages to be viewed on a tty or printed on a line printer
$CATSET	  = "$NROFF -h -mandoc -";

$CATSET  .= " | $COL" if $COL;

# Command to typeset a man page
$TYPESET  = "$TROFF -mandoc";


# flags: GNU likes -i, BSD doesn't; both like -h, but BSD doesn't document it
# if you don't put -i here, i'll make up for it later the hard way
#$EGREP = '/usr/local/bin/egrep';	
#if (-x $EGREP) {
    #$EGREP .= ' -i -h';
#} else {
    $EGREP = '/usr/bin/egrep';
    unless (-x $EGREP) {
	$EGREP = '';
    } else {
	$EGREP .= ' -h';
    }
#} 

# sections that have verbose aliases
# if you change this, change the usage message
#
# if you put any of these in their own trees, comment them out and make 
# a link in $MANALT so people can still say 'man local foo'; for local,
#	cd $MANALT; ln -s . local
# for the other trees (new, old, public) put either them or links
# to them in $MANALT
#
%SECTIONS = (				
    'local',	'l',
    'new',	'n',
    'old',	'o',
    'public',	'p' );

# turn this on if you want linked (via ".so" or otherwise) man pages
# to be found even if the thing they are linked to doesn't know it's
# being linked to -- that is, its NAME section doesn't have reference
# to it.  eg, if you call a man page 'gnugrep' but it's own NAME section
# just calls it grep, then you need this.  usually a good idea.
#
$STUPID_SO	= 1;  

# --------------------------------------------------------------------------
# end configuration section
# --------------------------------------------------------------------------

# CONVEX RCS keeps CHeader; others may prefer Header
($bogus, $version) = split(/:\s*/,'$CHeader: man 0.41 91/10/28 13:48:01 $',2);
chop($version); chop($version);

require 'getopts.pl';

$winsize = "\0" x 8;
$TIOCGWINSZ = 0x40087468;

$isatty = -t STDOUT;
if (ioctl(STDIN, $TIOCGWINSZ, $winsize)) {
    ($rows, $cols, $xpixel, $ypixel) = unpack('S4', $winsize);
} else {
    ($rows, $cols) = (24, 80);
}

%options = (
    'man',	'T:m:P:M:S:fkltvwdguhaAiDKn',
    'apropos',	'm:P:MvduaK',
    'whatis',	'm:P:M:vduh',
    'whereis',	'm:P:M:vduh'
);

($program = $0) =~ s,.*/,,;

$apropos = $program eq 'apropos';
$whatis  = $program eq 'whatis';
$whereis = $program eq 'whman';
$program = 'man' unless $program;

&Getopts($options = $options{$program}) || &usage;

if ($opt_u) {
    &version if $opt_v;
    &usage;
    # not reached
} 

if ($opt_v) {
    &version;
    exit 0;
}

&usage if $#ARGV < 0;

$MANPATH = $opt_P 	if $opt_P;	# backwards contemptibility
$MANPATH = $opt_M 	if $opt_M;

$hard_way = $opt_h	if $opt_h;

if ($opt_T) {
    $opt_t = 1;
    $TYPESET =~ s/$TROFF/$opt_T/;
    $TROFF = $opt_T;
} 

$MANPATH = "$MANALT/$opt_m"		# want different machine type (undoc)
			if $machine = $opt_m;

$MANSECT = $opt_S	if $opt_S;	# prefer our own section ordering

$whatis = 1		if $opt_f;
$apropos = 1		if $opt_k || $opt_K;
$fromfile = 1		if $opt_l;
$whereis = 1  		if $opt_w;
$grepman = 1		if $opt_g;	
$| = $debug = 1		if $opt_d;
$full_index = 1 	if $opt_i;
$show_all = 1		if $opt_a;
$stripBS = 1		if $opt_D;
$query_all = $opt_A	if $opt_A;

$roff = $opt_t ? 'troff' : 'nroff';   # for indirect function call


# maybe they said something like 'man vax ls'
if ($#ARGV > 0) {
    local($machdir) = $MANALT . '/' . $ARGV[0];
    if (-d $machdir) {
	$MANPATH = $machdir;
	$machine = shift;
    } 
} 

@MANPATH = split(/:/,$MANPATH);

# assign priorities to the sections he cares about
# the nearer the front the higher the sorting priority
$secidx = 0;
$delim = ($MANSECT =~ /:/) ? ':' : ' *';
for (reverse split(/$delim/, $MANSECT)) {
    if ($_ eq '') {
	warn "null section in $MANSECT\n";
	next;
    } 
    $MANSECT{$_} = ++$secidx;
} 


if ($whatis) {
    &whatis;
} elsif ($apropos) {
    &apropos;
} elsif ($whereis) {
    &whereis;
} elsif ($grepman) {
    &grepman;
} else {
    &man;
} 

exit $status;

# --------------------------------------------------------------------------
# fill out @whatis array with all possible names of whatis files
# --------------------------------------------------------------------------
sub genwhatis {
    local($elt,$whatis);

    for $elt (@MANPATH) {
	$whatis = "$elt/whatis";
	if (-f $whatis) {
	    push(@whatis, $whatis);
	} else {
	    warn "$whatis: $!\n";# if $opt_M || $opt_P; # they asked for it
	} 
    } 

    die "$program: No whatis databases found, please run makewhatis\n" 
	if $#whatis < 0;
} 

# --------------------------------------------------------------------------
# run whatis (man -f)
# --------------------------------------------------------------------------
sub whatis {
    local($target, %seeking, $section, $desc, @entries);

    &genwhatis;

    for $target (@ARGV) { $seeking{$target} = 1; } 

    if ($hard_way) {
	&slow_whatis;
    } else { 
	&fast_whatis;
    }

    for $target (keys %seeking) {
	print "$program: $target: not found.\n";
	$status = 1;
    } 
} 

# --------------------------------------------------------------------------
# do whatis lookup against dbm file(s)
# --------------------------------------------------------------------------
sub fast_whatis {
    local($entry, $cmd, $page, $section, $desc, @entries);

    for $INDEX (@whatis) {
	unless (-f "$INDEX.db" && dbmopen(INDEX,"$INDEX.db",0444)) {
	    warn "$program: No dbm file $INDEX.db: $!\n" if $debug; 
	    #$status = 1;
	    if (-f $INDEX) {
		local(@whatis) = ($INDEX);  # dynamic scoping obfuscation
		&slow_whatis;
	    }
	    next;
	} else {
	    warn "$program: dbmopened $INDEX.db";
	} 
       	for $target (@ARGV) {
	    local($ext);
	    @entries = &quick_fetch($target,'INDEX');
	    next unless @entries;
	    # $target =~ s/([^\w])/\\$1/g;
	    for $entry (@entries) {
		($cmd, $page, $section, $desc) = split(/\001/, $entry);
		#  STUPID_SO is one that .so's that reference things that
		#  don't know they are being referenced.  STUPID_SO may cause
		#  some peculiarities.
		unless ($STUPID_SO) {
		    next unless $cmd =~ /$target/i || $cmd =~ /\.{3}/;
		}

		delete $seeking{$target};
		($ext) = $page =~ /\.([^.]*)$/;
		printf("%-20s - %s\n", "$cmd ($ext)", $desc);
	    }
	} 
	dbmclose(INDEX);
    } 
    
} 

# --------------------------------------------------------------------------
# do whatis lookup the hard way
# --------------------------------------------------------------------------
sub slow_whatis {
    local($query);
    local($WHATIS);

    for (@ARGV) { s/([^\w])/\\$1/g; } 

    $query = '^[^-]*\b?(' . join('|',@ARGV) . ')\b[^-]* -';

    if ($EGREP)  {
	if (&run("$EGREP '$query' @whatis")) {
	    # pity can't tell which i found
	    %seeking = ();
	}
    } else {
	foreach $WHATIS (@whatis)  {
	    unless (open WHATIS) {
		warn "can't open $WHATIS: $!\n";
		next;
	    } 
	    while (<WHATIS>) {
		next unless /$query/i;
		($target = $+) =~ y/A-Z/a-z/;
		delete $seeking{$target};
		print;
	    } 
	    close WHATIS;
	} 
    } 
} 

# --------------------------------------------------------------------------
# run apropos (man -k)
# --------------------------------------------------------------------------
sub apropos {
    local($_, %seeking, $target, $query);
    &genwhatis;  

    for (@ARGV) { s/(\W)/\\$1/g unless $opt_K; }

    if ($EGREP)  {

	# fold case on apropos args
	for (@ARGV) { 
	    y/A-Z/a-z/; 
	    $seeking{$_} = 1; 
	} 
	$query = join('|',@ARGV);

	# need to fake a -i flag?
	unless ($EGREP =~ /-\w*i/) {
	    local($C);
	    local(@pat) = split(//,$query);
	    for (@pat) {
		($C = $_) =~ y/a-z/A-Z/ && ($_ = '[' . $C . $_ . ']');
	    } 
	    $query = join('',@pat);
	} 
	if (&run("$EGREP '$query' @whatis | $PAGER")) {
	    %seeking = ();
	} 
    } else {  # use perl
	local($code) = <<'EOF';
	if ($isatty) {
	    $pid = open(PAGER, "| $PAGER");
	    sleep 1;
	    select(PAGER);
	}
	foreach $WHATIS (@whatis) {
	    unless (open WHATIS) {
		warn "can't open $WHATIS: $!\n";
		next;
	    } 
	    WHATIS: while (<WHATIS>) {
EOF
	    for (@ARGV) {
		if ($opt_K && split(/\|/) > 1) { # speed hack
		   $code .= "OPLOOP: {\n";
		   for (@_) { $code .= "\tlast OPLOOP if /$_/i;\n"; } 
		   $code .= "next WHATIS; }\n";
		} else {
		    $code .= "    next WHATIS unless /$_/i;\n";
		}
	    } 
	    $code .= <<'EOF';
		print;
	    }
	    close WHATIS;
	}
EOF
	print "$code\n" if $debug;
	eval $code;
	if ($@ =~ /(.*)at \(eval\) line (\d+)/) {
	    ($message, $line) = ($1, $2);
	    if ((split(/\n/,$code))[$line-1] =~ /next unless/) {
		warn "EVAL ERROR: $@ $code" if $debug;
		die "$0: $message\n";
	    } else {
		die $@;
	    } 
	} elsif ($@) {
	    die $@;
	} 
    } 
    close PAGER if $isatty;
}

# --------------------------------------------------------------------------
# print out usage message via pager and exit
# --------------------------------------------------------------------------
sub usage {
    unless ($opt_u) {
	warn "usage: $program [-flags] topic ...\n";
	warn "        (use -u for long usage message)\n";
    } else {
	open (PIPE, "| $PAGER");
	print PIPE <<USAGE;  # in case he wants a page
USAGE SUMMARY: 
    man [-flags] [section] page[/index] ...
	(section is [1-8lnop], or "new", "local", "public", "old")
	(index is section or subsection header)

    man [-flags] -f topic ...  
	(aka "whatis")

    man [-flags] -k keyword ...
	(aka "apropos")

FLAGS: (most only make sense when invoked as 'man')
    -a		show all possible man pages for this topic
    -A		ask which selection if several available

    -l file	do man processing on local file
    -f topic	list table of contents entry for topic
    -k keyword	give table of contents entries containing keyword
    -K pattern  as -K but allow regexps
    -g pattern  grep through all man pages for patterns
    -w topic    which files would be shown for a given topic
    -i topic    show section and subsection index for use with topic/index

    -M path	use colon-delimited man path for searching (also as -P)
    -S sects	define new section precedence 

    -t		troff the man page
    -T path	call alternate typesetter on the man page

    -d		print out all system() commands before running them
    -h		do all lookups the hard way, ignoring any DBM files
    -u		this message
    -v		print version string
    -D		strip backspaces from output

ENVIRONMENT:
    \$PAGER	pager to pipe terminal-destined output through 
    \$MANPATH	like -M path
    \$MANSECT	like -S sects
    \$MANALT	used for alternate hardware types (or obsolete -m flag)
    \$TROFF	like -T path

CURRENT DEFAULTS:
    PAGER	$PAGER
    MANPATH	$MANPATH
    MANSECT	$MANSECT
    MANALT	$MANALT
    TROFF	$TROFF

NOTES:  (\$manroot is each component in \$MANPATH)
    * If \$manroot/whatis DBM files do not exist, a warning will be 
	printed (if -d flag) and -h will be assumed for that \$manroot only.
    * If \$manroot/tmac.an exists, it will be used for formatting 
	instead of the normal -man macros.
    * Man pages may be compressed either in (for example) man1.gz/who.1 
        or man1/who.1.gz; cat pages will go into corresponding places.
    * If the man page contains .EQ or .TS directives, eqn and/or tbl
        will be invoked as needed at format time.
USAGE
	close PIPE;
    }
    warn "couldn't run long usage message thru $PAGER?!?!\n" if $?;
    exit 1;
}

# --------------------------------------------------------------------------
# lookup a given key in the given man root; returns list of hits
# --------------------------------------------------------------------------
sub fetch {
    local($key,$root) = @_;
    local(%recursed);

    return $dbmopened{$root}
	? &quick_fetch($key,$root)
	: &slow_fetch($key,$root);
}

# --------------------------------------------------------------------------
# do a quick fetch of a key in the dbm file, recursing on indirect references
# --------------------------------------------------------------------------
sub quick_fetch {
    local($key,$array) = @_;
    local(@retlist) = ();
    local(@tmplist) = ();
    local($_, $entry);
    local($name, $ext);
    local(@newlist);

    return () unless $entry = $$array{$key};;

    @tmplist = split(/\002/, $entry);
    for (@tmplist) {
	if (/\001/) {
	    push(@retlist, $_);
	} else {
	    ($name, $ext) = /(.+)\.([^.]+)/;
	    push(@retlist, 
		grep(/[^\001]+\001[^\001]+\001${ext}\001/ || /[^\001]+${ext}\001/,
			&quick_fetch($name, $array)))
			                    unless $recursed{$name}++;

	# explain and diction are near duplicate man pages referencing
	# each other, requiring the $recursed check.  one should be removed
	}
    } 
    return @retlist;
} 

# --------------------------------------------------------------------------
# do a slow fetch for target using perl's globbing notation
# --------------------------------------------------------------------------
sub slow_fetch {
    local($target,$root) = @_;
    local($glob, $stem, $entry);

    $target =~ s/(\W)/\\$1/g;  # for str$round(3V) or /bin/[

    if ($want_section) {
	if ($MANSECT{$want_section}) {
	    $stem = $want_section;
	} else {
	    $stem = substr($want_section,0,1);
        } 
	$glob = "man$stem*";
    } else {
	$glob = 'man*';
    } 
    $glob = "$root/$glob/$target.*";
    return <${glob}>;
}

# --------------------------------------------------------------------------
# run 'man -w'
# --------------------------------------------------------------------------
sub whereis {
    local($target, @files);

    foreach $target (@ARGV) {
	@files = &find_files($target);
	if ($#files < $[) {
	    warn "$program: $target not found\n";
	    $status = 1;
	} else {
	    print "$target: " if $#ARGV;
	    for (@files) { print &verify($_), " "; }
	    print "\n";
	}
    } 
} 


# --------------------------------------------------------------------------
# what are the file names matching this target?
# --------------------------------------------------------------------------
sub find_files {
    local($target) = @_;
    local($root, $entry);
    local(@retlist) = ();
    local(@tmplist) = ();
    local(@entries) = ();
    local($tar_regx);
    local($found) = 0;
    # globals: $vars, $called_before, %dbm, $hard_way (kinda)

    $vars = 'dbm00';  # var for magic autoincrementation

    ($tar_regx = $target) =~ s/(\W)/\\$1/g;  # quote meta

    if (!$hard_way && !$called_before++) {
	# generate dbm names
	for $root (@MANPATH) {
	    $dbm{$root} = $vars++; # magic incr
	    unless (-f "$root/whatis.db" 
		    && dbmopen(%$root,"$root/whatis.db",undef)) 
	    {
		warn "No dbm file for $root/whatis: $!\n" 
		    if $opt_M || $opt_P || $debug;
		#$status = 1;
		next;
	    } else {
		warn "opened $root/whatis.db" if $debug;
	    } 
	    $dbmopened{$root} = 1;
	}
    } 

    for $root (@MANPATH) {
	local($fullname);
	@tmplist = ();
	#if ($hard_way || !$dbmopened{$root})  {
	if ($hard_way)  {
	    next unless -d $root;
	    warn "slow fetch on $target in $root\n" if $debug;
	    @tmplist = &slow_fetch($target,$root);
	} else {
	    @entries = &fetch($target,$root);
	    next if $#entries < 0;

	    for $entry (sort @entries) {
		($cmd, $page, $section, $desc) = split(/\001/, $entry);

		# STUPID_SO is so that .so's that reference things that
		# don't know they are being referenced.  STUPID_SO may
		# cause peculiarities.
		unless ($STUPID_SO) {
		    next unless $cmd =~ /$tar_regx/i || $cmd =~ /\.{3}/;
		}
		push(@tmplist, "$root/man$section/$page");
	    }
	}
	push(@retlist, sort bysection @tmplist);
	last if $#retlist >= 0 && $hard_way;
    }
#    unless (@retlist || $hard_way) {
#	# shameless (ab?)use of dynamic scoping
#	local($hard_way) = 1;
#	warn "recursing on find_files\n" if $debug;
#	return &find_files($target);
#    } 
     return &trimdups(@retlist);
} 

# --------------------------------------------------------------------------
# run a normal man command
# --------------------------------------------------------------------------
sub man {
    local($target,$page);


    while (@ARGV) {
	undef $idx_topic;

	&get_section;
	$target = shift @ARGV;

	if (!$fromfile && $target =~ m!^([^/]+)/(.*)!) {
	    if (!$isatty) {
		warn "$program: no tty, so no pager to prime with index\n";
		$target = $1;
	    }  else {
		($target, $idx_topic) = ($1, $2);
	    } 
	} else {
	    undef $idx_topic;
	} 

	if ($show_all) {
	    local(@pages);
	    local($was_defined) = defined $idx_topic;
	    @pages = &find_files($target);
	    if (!@pages) {
		&no_entry($target);
		next;
	    } 
	    while ($tpage = shift @pages) {
		undef $idx_topic unless $was_defined;
		do $roff(&verify($tpage));
		&prompt_RTN("to read $pages[0]") 
		    if $roff eq 'nroff' && @pages;
	    } 
	} else {
	    $target = &get_page($target) unless $fromfile;
	    do $roff($target) if $target;
	}
	&prompt_RTN("to read man page for $ARGV[0]") 
	    if $roff eq 'nroff' && @ARGV;
    } 
} 

# --------------------------------------------------------------------------
# find out if he wants a special section and save in $want_section
# --------------------------------------------------------------------------
sub get_section {
    local($section) = $ARGV[0];

    # interpret stty(1) as 1 stty
    if ($section =~ /^(\S+)\((\S*)\),?\s*$/) {
	shift @ARGV;
	unshift(@ARGV, $section = $2, $1);
    } 

    $section =~ tr/A-Z/a-z/;


    if (defined $SECTIONS{$section}) {
	$want_section = $SECTIONS{$section};
	shift @ARGV;
    }  elsif (defined($MANSECT{$section}) || $section =~ /^\d\S*$/i) { 
	$want_section = shift @ARGV;
    } else {
	return;
    } 

    $want_section =~ tr/A-Z/a-z/;

    die "But what do you want from section $want_section?\n" 
	if $want_section && $#ARGV < 0;
}

# --------------------------------------------------------------------------
# pick the first page matching his target and search orders
# --------------------------------------------------------------------------
sub get_page {
    local($target) = @_;
    local(@found, @want);

    unless (@found = &find_files($target)) {
	&no_entry($target);
	return '';
    } 

    if (!$want_section) {
	@want = @found;
    } else {{
	local($patsect); # in case it's section 3c++ 
	($patsect = $want_section) =~ s/(\W)/\\$1/g;

	# try exact match first
	last if @want = grep (/\.$patsect$/, @found);

	# otherwise how about a subsection
	last if @want = grep (/\.$patsect[^.]*$/, @found);

	# maybe it's in the wrong place (mano is notorious for this)
	last if @want = grep (/man$patsect[^.]*\//, @found);

	&no_entry($target);
	return '';
    }}

    for (@want) { $_ = &verify($_) ; }
    $found = $want[0];

    if (@want > 1 && $query_all) {
	local($ans, $i);

	select(STDERR);

	print "There are ", 0+@want, 
	    " manual entries available for $target:\n";
	for ($i = 0; $i <= $#want; $i++) {
	    printf "%3d\t%s\n", $i+1, $want[$i];
	} 
	{
	    print "Which section would you like? (select 0 for all) ";
	    ($ans = <STDIN>) ? chop($ans) : ($ans = "\004");

	    exit if $ans eq "\004";
	    redo if $ans eq '';

	    if ($ans eq '0') {
		# more dynamic scope abuse
		local(@ARGV) = ($target);
		local($show_all) = 1;
		&man;
		return '';
	    } 
	    if (--$ans > $#want) {
		print "But we only have ",1+$#want, " man pages!\n";
		redo;
	    } 

	    $found = $want[$ans];
	}
    } 


    select(STDOUT);

    $found;
}

# --------------------------------------------------------------------------
# figure out full path name of man page, which may have been compressed
# --------------------------------------------------------------------------
sub verify {
    local($path) = @_;
    local($orig) = $path;

    return $path if -f $path;

    if ($COMPRESS_PAGE) {
	$path .= '.gz';
	return $path if -f $path;
	$path =~ s/.gz//;
    } 

    if ($COMPRESS_DIR) {
	$path =~ s-(/[^/]*)$-.gz$1-;
	return $path if -f $path;
    } 

    warn "$program: $orig has disappeared -- rerun makewhatis\n";
    $status = 1;
    return '';
}


# --------------------------------------------------------------------------
# whine about something not being found
# --------------------------------------------------------------------------
sub no_entry {
    print STDERR "No manual entry for $_[0]";
    if ($machine || $want_section) {
	print STDERR " in";
	print STDERR " section $want_section of" if $want_section;
	print STDERR " the";
	print STDERR " $machine" if $machine;
	print STDERR " manual";
    }
    print STDERR ".\n";
    $status = 1;
} 

# --------------------------------------------------------------------------
# order by section.  if the complete extension has a section
# priority, use that.  otherwise use the first char of extension
# only.  undefined priorities are lower than any defined one.
# --------------------------------------------------------------------------
sub bysection {
    local ($e1, $e2, $p1, $p2, $s1, $s2);

    ($s1, $e1) = $a =~ m:.*/man([^/]+)/.*\.([^.]+)(\.gz)?$:;
    ($s2, $e2) = $b =~ m:.*/man([^/]+)/.*\.([^.]+)(\.gz)?$:;

    $e1 = $s1 if $e1 !~ /^${s1}.*/;
    $e2 = $s2 if $e2 !~ /^${s2}.*/;

    $p1 = $MANSECT{$e1} || $MANSECT{substr($e1,0,1)};

    $p2 = $MANSECT{$e2} || $MANSECT{substr($e2,0,1)};

    $p1 == $p2 ? $a cmp $b : $p2 <=> $p1;
} 

# --------------------------------------------------------------------------
# see whether they want to start at a subsection, then run the command
# --------------------------------------------------------------------------
sub run_topic {
    local($_);
    local($menu_rtn) = defined $idx_topic && $idx_topic eq '';
    {
	&append_sub_topic;
	last if $idx_topic eq "\004";
	if ($idx_topic eq '0') {
	    $menu_rtn = 0;
	    $idx_topic = '';
	    $command =~ s: '\+/[^']*'::;
	}
	$fromfile ? &reformat($command) : &run($command);
	if ($menu_rtn) {
	    $idx_topic = '';
	    &prompt_RTN("to return to the index");
	    $command =~ s! '\+/.*$!!;
	    redo;
	} 
    }
    
} 

# --------------------------------------------------------------------------
# run through the typesetter
# --------------------------------------------------------------------------
sub troff {
    local ($file) = $_[0];
    local ($command);
    local ($manroot);
    local ($macros);

    ($manroot) = $file =~ m,^(.*)/man([^\.]*)(\.gz)?/([^/]*),;

    $command = ((($file =~ m:\.gz:) 
			? $ZCAT 
			: $CAT) 
		. " < $file | $TYPESET");

    $command =~ s,-man,$manroot/tmac.an, if -e "$manroot/tmac.an";

    &insert_filters($command,$file);
    &run($command);
} 

# --------------------------------------------------------------------------
# just run a regular nroff, possibly showing the index first.
# --------------------------------------------------------------------------
sub nroff {
    local($manpage) = $_[0];
    local($catpage);
    local($tmppage);
    local($command);
    local(@saveidx);
    local($manroot);
    local($macros);
    local($intmp);
    local(@st_cat, @st_man);

    die "trying to nroff a null man page" if $manpage eq '';

    umask 022;

    if ($full_index) {
	&show_index($manpage);
	return;
    } 
    if ($fromfile) {
	$command = (($manpage =~ m:\.gz/:) ? $ZCAT : $CAT)
			. " < $manpage | $CATSET";
	&insert_filters($command, $manpage);
    } else {
	require 'stat.pl' unless defined &Stat;   
	# compiled version has this already


	($catpage = $manpage) 
	    =~ s,^(.*)/man([^\.]*)(\.gz)?/([^/]*)$,$1/cat$2/$4,;

	$manroot = $1;

	# Does the cat page exist?
	if (! -f $catpage && $COMPRESS_DIR){
	    # No, maybe it is compressed?
	    if (-f "$1/cat$2.gz/$4"){
		# Yes it was.
		$catpage = "$1/cat$2.gz/$4";
	    } else {
		# Nope, the cat file doesn't exist.
	    	# Prefer the compressed cat directory if it exists.
	    	$catpage = "$1/cat$2.gz/$4" 
		    if $catpage !~ /\.gz$/ && -d "$1/cat$2.gz";
	    }
	}


	@st_man = &Stat($manpage);

	if ($st_man[$ST_SIZE] == 0) {
	    warn "$program: $manpage is length 0!\n";
	    $status = 1;
	    return;
	} 

	@st_cat = &Stat($catpage);


	if ($st_cat[$ST_MTIME] < $st_man[$ST_MTIME]) {

	    $command = (($manpage =~ m:\.gz:) ? $ZCAT : $CAT)
			. " < $manpage | $CATSET";

	    $command = &insert_filters($command, $manpage);
	    $command =~ s,-man,$manroot/tmac.an, if -e "$manroot/tmac.an";

	    ($catdir = $catpage) =~ s!^(.*/?cat[^/]+)/[^/]*!$1!;

	    chdir $manroot;

	    $tmppage = "$catpage.$$";

	    unless (-d $catdir && -w _ 
		    && open(tmppage, ">$tmppage") # usually EROFS
		    && close(tmppage) )
	    {
		$catpage = $tmppage = "/tmp/man.$$";
		$intmp = 1;
	    }

	    printf STDERR "Reformatting page.  Please wait ... " if $isatty;

	    $command .= "| $COMPRESS" if $catpage =~ /\.gz/;
	    $command .= "> $tmppage";

	    $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'HUP'} = $SIG{'TERM'}  
		= 'tmp_cleanup';

	    $SIG{'PIPE'} = 'PLUMBER';

REFORMAT:   { unless (&reformat($command)) {
		warn "$program: nroff of $manpage into $tmppage failed\n"
		    unless $@;
		unlink $tmppage unless $debug;
		if (!$intmp++) {
		    $catpage = $tmppage = "/tmp/man.$$";
		    warn "$program: hang on... retrying into $tmppage\n";
		    $command =~ s/> \S+$/> $tmppage/;
		    $status = 0;
		    redo REFORMAT;
		} else {
		    #$status = 1;
		    return;
		}
	    }} 
	    warn "done\n" if $isatty;

	    $intmp || rename($tmppage,$catpage) || 
		die "couldn't rename $tmppage to $catpage: $!\n";
	    
	    $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'HUP'} = $SIG{'TERM'} =
		$SIG{'PIPE'} = 'DEFAULT';

	} 
	$command = (($catpage =~ m:\.gz:)
			? $ZCAT
			: $CAT)
		    . " < $catpage";
    }
    if (-z $catpage) {
	unlink $catpage;
	die "$program: $catpage was length 0; disk full?\n";
    } 
    $command .= "| $UL" 		if $UL;
    $command .= "| $SED 's/.\b//g'" 	if $stripBS;

    if ($isatty) {  
        $command .= "| $PAGER";
        # If the pager is less, use the man page as the prompt, even if pipe
        if ($is_less) { 
            # Escape all periods because less interprets them.  We also
            # need to add an extra '\' to escape the shell intrepetation
            # of '\'.  We also need to make a copy of $manpage, because
            # the substitution trashes the string and it is needed later.
            ($lessprompt = $manpage) =~ s/\./\\./g;
	    $lessprompt = "$lessprompt byte %bB?s/%s .?e(END) :?pB%pB\\%.%t"
	        if $ENV{'LESS'} =~ /M/; # he wants a long prompt
            $command .= " '-MPM$lessprompt'";
        }
    }

    &run_topic;
    unlink($tmppage) if $intmp;
} 


# --------------------------------------------------------------------------
# modify $command to prime the pager with the subsection they want
# --------------------------------------------------------------------------
sub append_sub_topic {
    if (defined $idx_topic)  {{
	local($key);
	last if $idx_topic eq '0';
	unless ($idx_topic) {
	    $idx_topic = &pick_index;
	    last if $idx_topic eq "\004" || $idx_topic eq '0';
	}
	if ($idx_topic =~ m!^/!) {
	    $command .= " '+$idx_topic'";
	    last;
	}
	unless ($key = &find_index($manpage, $idx_topic)) {
	    warn "No subsection $idx_topic for $manpage\n\n";
	    $idx_topic = '';
	    redo;
	}
	$key =~ s/([!-~])/$1.$1/g unless $is_less;
	$command .= " '+/^[ \t]*$key'";
    }}
}


# --------------------------------------------------------------------------
# present subsections and let user select one
# --------------------------------------------------------------------------
sub pick_index {
     local($_);
     print "Valid sections for $page follow.  Choose the section\n";
     print "index number or string pattern. (0 for full page, RTN to quit.)\n\n";
     &show_index;
     print "\nWhich section would you like? ";
     ($_ = <STDIN>) ? chop : ($_ = "\004");
     $_ = "\004" if 'quit' =~ /^$_/;
     return $_;
} 

# --------------------------------------------------------------------------
# strip arg of extraneous cats and redirects	
# --------------------------------------------------------------------------
sub unshell {
    $_[0] =~ s/^\s*cat\s*<?\s*([^\s|]+)\s*\|\s*([^|]+)/$2 < $1/;
    $_[0] =~ s/^([^|<]+)<([^Z|<]+)$/$1 $2/;
    ($roff eq 'troff') && $_[0] =~ s#(/usr/man/pr\S+)\s+(\S+)#$2 $1#;
}

# --------------------------------------------------------------------------
# call system on command arg, stripping of sh-isms and echoing for debugging
# --------------------------------------------------------------------------
sub run {
    local($command) = $_[0];

    &unshell($command);

    if ( $opt_n ) {
	warn "$command\n";
	return 1;
    }

    warn "running: $command\n" if $debug;
    if (system $command) {
	$status = 1;
	printf STDERR "\"%s\" exited %d, sig %d\n", $command, 
	    ($? >> 8), ($? & 255) if $debug;
    }
    return ($? == 0);
} 

# --------------------------------------------------------------------------
# check if page needs tbl or eqn, modifying command if needed
# add known problems for PR directory if applicable
# --------------------------------------------------------------------------
sub insert_filters {
    local($filters,$eqn, $tbl, $_);
    local(*PAGE);
    local($c, $PAGE) = @_;
    local($page,$sect, $prs, $prdir);

    ( $page = $PAGE ) =~ s/\.gz//;
    ($prdir = $page) =~ s#/[^/]*$##;
    $prdir =~ s#man([^/]*)$#pr$1#;
    $page =~ s#.*/([^/]+)$#$1#;

    $PAGE = "$ZCAT < $PAGE|" if $PAGE =~ /\.gz/;

    (open PAGE) || die ("$program: can't open $PAGE to check filters: $!\n");
    warn "open $PAGE to check for filters in $_[0]\n" if $debug;

    while (<PAGE>) {
	if (/^\.EQ/) {
	    $_ = <PAGE>;
	    $eqn = 1 unless /\.(if|nr)/;  # has eqn output not input
	} 
	if (/^\.TS/) {
	    $_ = <PAGE>;
	    $tbl = 1 unless /\.(if|nr)/;  # has tbl output not input
	} 
	last if $eqn && $tbl;
    } 
    close PAGE;

    if ($roff eq 'troff') {
	$eqn && $_[0] =~ s/(\S+roff)/$EQN | $1/;
	$tbl && $_[0] =~ s/(\S+roff)/$TBL | $1/;
    } else { # nroff
	$eqn && $_[0] =~ s/(\S+roff)/$NEQN | $1/;
	$tbl && $_[0] =~ s/(\S+roff)/$NTBL | $1/;
    }

    ($sect) = $page =~ /\.(\d)[^.]*$/;
    $prs = "$prdir/$page";
    if (-e $prs) {
	warn "found PRs for $page\n" if $debug;
	if ($roff eq 'nroff')  {
	    $_[0] =~ s/ - / - $prs/;
	} else {
	    $_[0] .= " $prs";
	} 
    } else {
	print "no PRS for $page in $prs\n" if $debug;
    } 
    $_[0];
} 

# --------------------------------------------------------------------------
# due to aliasing the dbase sometimes has the same thing twice
# --------------------------------------------------------------------------
sub trimdups {
    local(%seen) = ();
    local(@retlist) = ();

    while ($file = shift) {
	push(@retlist,$file) unless $seen{$file}++;
    } 
    return @retlist;
} 

# --------------------------------------------------------------------------
# just print the version
# --------------------------------------------------------------------------
sub version  {
    warn "$program: version is \"$version\"\n" ;
}

# --------------------------------------------------------------------------
# create and display subsection index via pager
# --------------------------------------------------------------------------
sub show_index {
    local($_);
    &load_index($_[0]);
    if ($#ssindex > ($rows - 4) && $isatty) {
	print "Hit <RTN> for $#ssindex subsections via pager: ";
	$_ = <STDIN>;
	local($SIG{'PIPE'}) = 'IGNORE';
	if ($no_idx_file) {
	    open (PAGER, "| $PAGER");
	    print PAGER @ssindex;
	    close PAGER;
	} else {
	    &run("$PAGER $idx_file");
	} 
    } else {
	print STDOUT @ssindex;
    }
} 

# --------------------------------------------------------------------------
# find closest match on index selection in full index
# --------------------------------------------------------------------------
sub find_index {
    local($manpage, $expr) = @_;
    local($_, @matches);

    &load_index($manpage);

    $expr =~ s!^/+!!;

    for (@ssindex) { 
	s/^\s*\d+\s+//; 
	s/\s+\d+\s*$//; 
    }

    if ($expr > 0) {
	return $ssindex[$expr];
    } else {
	$ssindex[0] = '';
	if (@matches = grep (/^$expr/i, @ssindex)) {
	    return $matches[0];
	} elsif (@matches = grep (/$expr/i, @ssindex)) {
	    return $matches[0];
	} else {
	    return '';
	}
    } 
} 

# --------------------------------------------------------------------------
# read in subsection index into @ssindex
# --------------------------------------------------------------------------
sub load_index {
    local($manpage)  = @_;
    $no_idx_file = 0;
    &getidx($manpage) if $#saveidx < 0;
    @ssindex = @saveidx;
    die "should have have an index for $manpage" if $#saveidx < 0;
} 

# --------------------------------------------------------------------------
# create subsection index is out of date wrt source man page
# --------------------------------------------------------------------------
sub getidx {
    local($manpage) = @_;
    local($is_mh);
    local($_, $i, %lines, %sec, $sname, @snames);
    local(@retlist, $maxlen, $header, @idx , @st_man, @st_idx);
    # global no_idx_file, idx_file

    ( $idx_file = $manpage ) =~ s:/man(\w+)(\.gz)?/:/idx$1/:;
    $idx_file =~ s/\.gz//;

    require 'stat.pl' unless defined &Stat;

    @st_man = &Stat($manpage);
    @st_idx = &Stat($idx_file);

    if ($st_man[$ST_MTIME] < $st_idx[$ST_MTIME]) {
	unless (open idx_file) {
	    warn "$program: can't open $idx_file: $!\n";
	    return ();
	} 
	@retlist = <idx_file>;
	close idx_file;
	return @saveidx = @retlist;
    } 

    if (!open(manpage, $manpage =~ /\.gz/ ? "$ZCAT < $manpage|" : $manpage)) {
    	warn "$program: can't open $manpage: $!\n";
	return ();
    }
    warn "building section index\n" if $debug;
    ($header = "Subsections in $manpage")  =~ s!/?\S*/!!;
    $maxlen = length($header);
    push(@snames, $sname = 'preamble');;

    # MH has these alias for sections and subsectdions
    if ($is_mh = $manpage =~ m:/mh/:) {
	%mh_sections = (
	    "NA", "NAME",
	    "SY", "SYNOPSIS",
	    "DE", "DESCRIPTION",
	    "Fi", "FILES",
	    "Pr", "PROFILE",
	    "Sa", "SEE ALSO",
	    "De", "DEFAULTS",
	    "Co", "CONTEXT",
	    "Hh", "HELPFUL HINTS",
	    "Hi", "HISTORY",
	    "Bu", "BUGS"
	);
	$mh_expr = join('|',keys %mh_sections);
    } 

    while (<manpage>) {
	if ($is_mh && /^\.($mh_expr)/) {
	    $sname = $mh_sections{$+};
	    $maxlen = length($sname) if $maxlen < length($sname); 
	    push(@snames,$sname);
	} 
	if (/^\.(?:s[sh]|ip)\s+(.*?)(\s*\d+)?$/i ) {
	    $line = $_;
	    $_ = $1;
	    s/"//g;
	    s/\\f([PBIR]|\(..)//g;	# kill font changes
	    s/\\s[+-]?\d+//g;		# kill point changes
	    s/\\&//g;			# and \&
	    s/\\\((ru|ul)/_/g;		# xlate to '_'
	    s/\\\((mi|hy|em)/-/g;	# xlate to '-'
	    s/\\\*\(..//g; 		# no troff strings
	    s/\\//g;		   	# kill all remaining backslashes 
	    $sname = $_;
	    $_ = $line;
	    $maxlen = length($sname) if $maxlen < length($sname); 
	    push(@snames,$sname);
	} 
	$lines{$sname}++;
    } 

    $mask = sprintf("%%2d   %%-%ds %%5d\n", $maxlen + 2);

    $no_idx_file = $idx_file eq $manpage || !open(idx, ">$idx_file");

    $line = sprintf(sprintf("Idx  %%-%ds Lines\n", $maxlen + 2), $header);
    @retlist = ($line);

    for ($i = 1; $i <= $#snames; $i++)  {
	push(@retlist, sprintf($mask, $i, $snames[$i], $lines{$snames[$i]}));
    } 
    if (!$no_idx_file) {
	warn "storing section index in $idx_file\n" if $debug;
	print idx @retlist;
	close idx;
    }
    return @saveidx = @retlist;
}

# --------------------------------------------------------------------------
# interrupted -- unlink temp page
# --------------------------------------------------------------------------
sub tmp_cleanup {
    warn "unlink $tmppage\n" if $debug;
    unlink $tmppage;
    die "Interrupted!\n";
} 

#--------------------------------------------------------------------------
# in case we die writing to the pipe
# --------------------------------------------------------------------------
sub PLUMBER {
    warn "unlink $tmppage\n" if $debug;
    unlink $tmppage;
    die "Broken pipe while reformating $manpage\n" ;
} 


# --------------------------------------------------------------------------
# print line with C\bC style emboldening 
# --------------------------------------------------------------------------
sub print {
    local($_) = @_;

    if (!$inbold) {
	print;
    } else {
	local($last);
	for (split(//)) {
            if ($last eq "\033") {
                print;
            } else {
                print /[!-~]/ ? $_."\b".$_ : $_;
            }
            $last = $_;
	}
    } 
}

# --------------------------------------------------------------------------
# reformat the page with nroff, fixing up bold escapes
# --------------------------------------------------------------------------
sub reformat { 
    local($_) = @_; 
    local($nroff, $col); 
    local($inbold) = 0;
    local($status);

    if ($NROFF_CAN_BOLD) {
	return &run($_);
    } 

    &unshell($_);
    ($nroff, $col) = m!(.*)\|\s*($COL.*)!;

    if ( $opt_n ) {
	warn "$_\n";
	return 1;
    }

    warn "$nroff | (this proc) | $col\n" if $debug;

    open (NROFF, "$nroff |");
    $colpid = open (COL, "| $col");

    select(COL);

    while (<NROFF>) {
	s/\033\+/\001/;
	s/\033\,/\002/;
	if ( /^([^\001]*)\002/ || /^([^\002]*)\001/ )  {
	    &print($1);
	    $inbold = !$inbold;
	    $_ = $';
	    redo;
	}   
	&print($_);
    }

    close NROFF;
    if ($?) { 
	warn "$program: \"$nroff\" failed! status=$?" if $debug;
	$status++;
    } 
    close COL;
    if ($?) {
	warn "$program: \"$col\" failed! status=$?" if $debug;
	$status++;
    }
    select(STDOUT);
    $status == 0;
} 

# --------------------------------------------------------------------------
# prompt for <RET> if we're a tty and have a non-stopping pager
# --------------------------------------------------------------------------
sub prompt_RTN {
    local($why) = $_[0] || "to continue";
    return unless $isatty;
    unless ($is_less && $ENV{'LESS'} !~ /E/) {
	print "Hit <RTN> $why: ";
	$_ = <STDIN>;
    }
}

# --------------------------------------------------------------------------
# dynamically determine MANPATH (if unset) according to PATH
# --------------------------------------------------------------------------
sub config_path {
    local($_);		# for traversing $PATH
    local(%seen);	# weed out duplicates
    local(*manpath);	# eventual return values

    if (defined $ENV{'MANPATH'}) {
	$manpath = $ENV{'MANPATH'};
    } else {
	for (split(/:/, $ENV{'PATH'})) {
	    next if $_ eq '.';
	    next if $_ eq '..';
	    s![^/+]*$!man! && -d && !$seen{$_}++ && push(@manpath,$_);
	}
	$manpath = join(':', @manpath);
    } 
    # $manpath;    # last expr is assign to this anyway
} 

# --------------------------------------------------------------------------
# grep through MANPATH for a pattern
# --------------------------------------------------------------------------
sub grepman {
    local($code, $_, $dir, $root, $FILE, $found);
    
    $code = "while (<FILE>) {\n";

    for (@ARGV) {
	s#/#\\/#g;
	$code .= <<EOCODE;
	    if (/$_/) { 
		print "\$path: \$_"; 
		\$found++;
		next; 
	    }
EOCODE
    } 

    $code .= "}\n";

    print "grep eval code: $code" if $debug;

    
    foreach $root ( split(/:/, $MANPATH)) {
	unless (chdir($root)) {
	    warn "can't chdir to $root: $!";
	    $status++;
	    next;
	} 
	foreach $dir ( <man?*> ) {
	    unless (chdir($dir)) {
		warn "can't chdir to $root/$dir: $!" if $debug;
		next;
	    } 
	    unless (opendir(DIR, '.')) {
		warn "can't opendir $root/$dir: $!" if $debug;
		next;
	    } 
	    foreach $FILE ( readdir(DIR) ) {
		next if $FILE eq '.' || $FILE eq '..';
		$path = "$root/$dir/$FILE";
		if ($FILE !~ /\S\.\S/ || !-f $FILE) {
		    print "skipping non-man file: $path\n" if $debug;
		    next;
		} 
		if ($FILE =~ /\.gz$/ || $dir =~ /\.gz$/) {
		    $FILE = "$ZCAT $FILE|";
		} 
		print STDERR "grepping $path\n" if $debug;
		unless (open FILE) {
		    warn "can't open $root/$dir/$FILE: $!";
		    $status++;
		    next;
		} 
		eval $code;
		die $@ if $@;
	    } 
	    unless (chdir ($root)) {
		warn "can't return to $root: $!";
		$status++;
		last;
	    } 
	} 
    } 
    exit ($status || !$found);
}