#!/pro/bin/perl

# perlman: man page viewer in Perl
#	Derived from examples of the "Advanced Perl Programming" book
#	from O'Reilly written by Sriram Srinivasan

$version = "1.02";

# Changes by H.Merijn Brand:
#	+ Auto background
#	+ Added optional scrollbars to ROtext (a.o.t. Text)
#	+ Use argument as default man-page
#	+ Quit button
#	+ Man-page file caching to reduce startup time
#	+ Removed rman, implementations inlined to enable underline and bold
#	+ Search auto-see, search next and -prev buttons w/ balloons
#	+ Man-page stack / History and buttons w/ balloons
#	+ Man-page page cache
#	+ PostScript (pre-pre-alpha)

use strict;
use GDBM_File;
use Fcntl;
use Cwd;
use Tk;

scan_man_dirs ();
print STDERR "Starting UI\n";
to_background ();
create_ui ();

def_show (shift);

MainLoop ();
exit 0;

#-------------------------------------------------------------------

sub to_background
{
    my $pid = fork;
    if ($pid < 0) {
	print STDERR "Unable to run in the background, cannot fork: $!\n";
	exit $?;
	}
    $pid && exit 0;
    } # to_background

my $menu_headings;	# "Headings" MenuButton
my $menu_stack;		# "History" MenuButton
my @manstack;		# Manpage history
my %manpage;		# Manpage cache
my $mancurrent;		# index to current manpage in history
my $ignore_case;	# 1 if check-button on in Search menu
my $match_type;		# -regexp or -exact. 
my $text;		# Main text widget
my $show;		# "Show" entry widget
my $search;		# "Search" entry widget
my $nextSearch;		# "Search Next" button to bind sub
my $prevSearch;		# "Search Prev" button to bind sub
my %sections;		# Maps section ("1", "3" ,"3n" etc.)
			#  to list of topics in that section
my %manfile;		# Holds the physical file for man page

sub def_show
{
    my $man = shift || return;
    $show->insert ("end", $man);
    show_man ();
    } # def_show

sub show_man
{
    my $entry = $show->get ();   # get entry from $show
    my ($man, $section) = ($entry =~ m/^([\w:]+)(\(.*\))?/);
    $man =~ m/\S/ || return;
    if ($section && (!is_valid_section ($section))) {
        undef $section;
	}

    # Erase everything to do with current page (contents, menus, marks)
    $text->delete ("1.0", "end");  # erase current page
    $text->insert ("end", "Getting \"$man\" .. please wait", "sct");
    $text->update ();

    $menu_headings->menu ()->delete (0, "end");

    my $mark;
    foreach $mark ($text->markNames) {  # remove all marks 
        $text->markUnset ($mark);
	}

    # UI is clean now. Get the man page
    $text->configure (-cursor => "watch");
    if (exists $manpage{$entry}) {
	$text->insert ("end", " (Cached)");
	$text->update ();
	}
    else {
	$text->insert ("end", " Formatting ...");
	$text->update ();
	my $cmd_line = get_command_line ($man, $section); # used by open
	unless (open (F, $cmd_line)) {
	    # Use the text widget for error messages 
	    $text->insert ("end", "\nError in running man");
	    $text->update ();
	    $text->configure (-cursor => "left_ptr");
	    return;
	    }
	$manpage{$entry} = [(<F>)];
	close F;
	}
    my @F = @{$manpage{$entry}};

    # Erase the "Formatting $man ..." message
    $text->delete ("1.0", "end");
    my $lines_added = 0;
    my $line;
    my $lead;
    my $prev = "";
    my $skip = 0;
    
    foreach my $line (@F) {
        $skip-- > 0 && next;
        unless ($lines_added) {
	    $line =~ m/^\s*$/	&& next;
	    ($lead) = ($line =~ m/^(\s+)/);
	    }
        $line =~ s/^$lead//;

        my $stripped = $line;
	chomp ($stripped);
	$stripped =~ s/\s+$//;
	1 while $stripped =~ s/.(.)/$1/;

        # Strip headers
        if ($stripped =~ m/^(\w+\(\d+\w*?\)|
                             user\s+contributed\s+perl\s+documentation|
                             perl\s+programmers\s+reference\s+guide|
                             gnu\s+tools
                             ) .*? \s\1
                           $
                          /ix) {
	    $skip = 1;	# Next line allways junk or empty
	    next;
	    }
	$prev eq "" && $stripped =~ m/^\s*
				       (\d{1,2}\s*[a-z]+|
	                                [a-z]+\s*\d{1,2},)
	                               \s*\d{4}
	                              $
	                             /ix && next;
	$prev eq "" && $stripped =~ m/^\s*
	                               perl\s*\d\.\d+
				       (,\s*patch\s*\d+)?
				      $
				     /ix && next;
	# Strip footers
	$stripped =~ m/^[-\.,\w\s]+
			\s-\s*\d+\s*-\s			# Page number
			[-\.,\w\s]+:[-,\w\s]+\s\d{4}	# Date
	               $
	              /x && next;			# Footer

        # Squeeze multiple blank lines producing only one blank line.
        $stripped eq "" && $prev eq "" && next;

        $lines_added = 1;
        $prev = $stripped;
        if ($line =~ m/^[A-Z]/) {  
            # Likely a section heading
            my $idx = $text->index ("end");
            $text->insert ("end", "$stripped\n\n", "sct");
            $menu_headings->command (
		-label   => $stripped,
		-command => [ sub { $text->see ($_[0])}, $idx ]);
	    $menu_headings->update ();	# It might be teared off
	    }
	else {
            # Underlining, Boldfacing and other unknown shit
            while ($line =~ s/(.)//) {
		my $o = $1;
		$text->insert ("end", $`);
		($line = $') =~ s/^(.)//;
		if ($1 eq $o) {			# Overstrike
		    $text->insert ("end", $1, "bd");
		    # $o can be any character
		    # 1 while s/^$o//; i.e. will fail on '/' and '\'
		    substr ($o, 0, 0) = "";
		    while (substr ($line, 0, 2) eq $o) {
			substr ($line, 0, 2) = "";	# Multiple overstrike
			}
		    }
		elsif ($o eq "_") {		# Underline
		    $text->insert ("end", $1, "ul");
		    }
		else {				# NYI
		    $text->insert ("end", $1);
		    }
		}
            $text->insert ("end", $line);
	    }
	}

    if ($lines_added) {
	unless ($mancurrent >= 0 && $manstack[$mancurrent] eq $entry) {
	    $mancurrent++;
	    $manstack[$mancurrent] eq $entry || splice @manstack, $mancurrent;
	    $manstack[$mancurrent] = $entry;
	    }
	}
    else {
        $text->insert ("end", "Sorry. No information found on $man$section");
	}

    $menu_stack->menu ()->delete (0, "end");
    foreach my $i (0 .. $#manstack) {
	$menu_stack->command (
	    -label   => $manstack[$i],
	    -command => sub {
		$mancurrent = $i;
		$show->delete ("0", "end");
		$show->insert ("end", $manstack[$i]);
		show_man ();
		});
	}
    $text->configure (-cursor => "left_ptr");
    } # show_man

sub show_ps
{
    my $entry = $show->get ();   # get entry from $show
    $entry =~ s/\((.*)\)$/.$1/;
    my $lst = $manfile{"$entry"} || return;
    my $file = $lst->[0] || return;	# Check for dups?
    # Still have to check if $file is gzipped, compressed and/or preformatted
    system "groff -man $file >/tmp/u.$<";
    # It shows, but after that, I lose control ....
    #my $xx = MainWindow->new ();
    #my $gs = $xx->Ghostscript ()->pack (-expand => "both");
    #$gs->Postscript (`cat /tmp/u.$<`);
    } # show_ps

sub get_command_line
{
    my ($man, $section) = @_; # Given topic and section, construct 
                              # Unix command-line
    $section =~ s/[()]//g; # remove parens (will succeed in undef)
    return "man $section $man 2>/dev/null |";
    } # get_command_line

sub create_ui
{
    my $top = MainWindow->new ();

    # MENU STUFF

    # Menu bar
    my $menu_bar = $top->Frame ()->pack (-side => "top", -fill => "x");

    # File menu
    my $menu_file = $menu_bar->Menubutton (
	-text        => "File",
	-relief      => "raised",
	-borderwidth => 2)->pack (
	    -side => "left",
	    -padx => 2);
    $menu_file->command (
	-label => "Location",
	-command => sub {
	    my $msg = MainWindow->new ();
	    my $ok = sub { $msg->destroy };
	    $msg->Button (
		-text    => "OK",
		-command => $ok)->pack (-side => "left");
	    $msg->Message (
		-takefocus => 1,
		-aspect    => 10000,
		-text      => join (", ", @{$manfile{$show->get ()}}))->pack (-side => "right");
	    $msg->after (15000, $ok);
	    });
    $menu_file->command (-label => "Quit", -command => \&exit);

    # History/Sections Menu
    $menu_stack    = $menu_bar->Menubutton (
	-text        => "History",
	-relief      => "raised",
	-borderwidth => 2)->pack (
	    -side => "left",
	    -padx => 2); 
    $menu_headings = $menu_bar->Menubutton (
	-text        => "Headings",
	-relief      => "raised",
	-borderwidth => 2)->pack (
	    -side => "left",
	    -padx => 2); 

    #Search menu 
    $match_type = "-regexp";
    $ignore_case = 1;
    my $search_mb = $menu_bar->Menubutton (
	-text        => "Search",
	-relief      => "raised",
	-borderwidth => 2)->pack (
	    -side => "left",
	    -padx => 2);

    # Regexp match
    $search_mb->radiobutton (
	-label    => "Regexp match",
	-value    => "-regexp",
	-variable => \$match_type);
    # Exact match
    $search_mb->radiobutton (
	-label    => "Exact match",
	-value    => "-exact",
	-variable => \$match_type);
    $search_mb->separator;
    # Ignore case
    $search_mb->checkbutton (
	-label    => "Ignore case?",
	-variable => \$ignore_case); 

    #Sections Menu
    my $menu_sections = $menu_bar->Menubutton (
	-text        => "Sections",
	-relief      => "raised",
	-borderwidth => 2)->pack (
	    -side => "left",
	    -padx => 2);

    # Populate sections menu with keys of % sections
    foreach my $section_name (sort keys %sections) {
        $menu_sections->command (
	    -label   => "($section_name)",
	    -command => [\&show_section_contents, $section_name]);
	}
    
    $menu_bar->Button (
	-text        => "Quit",
	-relief      => "raised",
	-borderwidth => 2,
	-command     => \&exit)->pack (-side => "right");
    $menu_bar->Button (
	-text        => "PS",
	-relief      => "raised",
	-borderwidth => 2,
	-command     => \&show_ps)->pack (-side => "right");

    # TEXT STUFF
    $text = $top->Scrolled ("ROText",
	-scrollbars => "osoe",
	-width      => 80,
	-height     => 40)->pack ();
    $text->configure (-cursor => "left_ptr");
    # Dynamically determine the 'bold' font (users allways want their own)
    my $font = $text->cget (-font);
    my @font = split m/-/, $$font;
    $font[3] = "bold";
    my $boldfont = join "-", @font;
    # Use xterm-color settings for attributes if available
    my $colorUL = $text->cget (-foreground);
    my $colorBD = $colorUL;
    foreach my $xrdb (`xrdb -q`) {
	$xrdb =~ m/\*(colorBD|colorUL)\s*:\s*(\S+)/ || next;
	$1 eq "colorBD" ? $colorBD : $colorUL = $2;
	}
    $text->tagConfigure ("sct", -font => $boldfont, -foreground => $colorBD);
    $text->tagConfigure ("bd",  -font => $boldfont);
    $text->tagConfigure ("ul",  -underline => 1,    -foreground => $colorUL);
    $text->bind ("<Double-1>", \&pick_word);

    @manstack = ();
    $mancurrent = -1;
    $top->Label (-text => "Show:")->pack (-side => "left");
    $show = $top->Entry (-width => 19)->pack (-side => "left");
    $show->bind ("<KeyPress-Return>", \&show_man);
    $top->Balloon (
	-background => "LightYellow2")->attach (
	    $top->Button (
		-font    => "spc08x14",
		-text    => "\x11",
		-command => sub {
		    $mancurrent > 0 || return;
		    show_current (--$mancurrent);
		    })->pack (-side => "left"),
	    -balloonmsg => "Push to go back in the man page history");
    $top->Balloon (
	-background => "LightYellow2")->attach (
	    $top->Button (
		-font    => "spc08x14",
		-text    => "\x10",
		-command => sub {
		    defined $manstack[$mancurrent + 1] || return;
		    show_current (++$mancurrent);
		    })->pack (-side => "left"),
	    -balloonmsg => "Push to go forward in the man page history");

    $top->Label (-text => "Search:")->pack (-side => "left");
    $search = $top->Entry (-width => 20)->pack (-side => "left");
    $search->bind ("<KeyPress-Return>", \&search);
    $top->bind ("<Key>/", sub { $search->focus; });
    $top->bind ("Meta<Key>/", sub { $search->focus; });

    $top->Balloon (
	-background => "LightYellow2")->attach (
	    $nextSearch = $top->Button (
		-font    => "spc08x14",
		-text    => "\x1E",
		-command => sub {})->pack (-side => "left"),
	    -balloonmsg => "Search up/backwards (wrapped)");
    $top->Balloon (
	-background => "LightYellow2")->attach (
	    $prevSearch = $top->Button (
		-font    => "spc08x14",
		-text    => "\x1F",
		-command => sub {})->pack (-side => "left"),
	    -balloonmsg => "Search down/forewards (wrapped)");
    } # create_ui

sub show_current
{
    my $idx = shift;
    $show->delete ("0", "end");
    $show->insert ("end", $manstack[$idx]);
    show_man ();
    } # show_current

sub is_valid_section
{
    my $section= shift;
    $section =~ m/\((.*?)\)/ || return 0;
    $section = $1;
    my $s;
    foreach $s (keys %sections) {
        if (lc ($s) eq lc ($section)) {
            return 1;
	    }
	}
    0;
    } # is_valid_section

sub pick_word
{
    my $start_index = $text->index ("insert wordstart");
    my $end_index = $text->index ("insert lineend");
    my $line = $text->get ($start_index, $end_index);
    my ($page, $section) = ($line =~ m/^([\w:]+)(\(.*?\))?/); 
    $page || return ;
    $show->delete ("0", "end");
    if ($section && is_valid_section ($section)) {
        $show->insert ("end", "$page${section}");
	}
    else {
        $show->insert ("end", $page);
	}
    show_man ();
    } # pick_word

sub show_section_contents
{
    my $current_section = shift;
    $text->delete ("1.0", "end");
    $menu_headings->menu ()->delete (0, "end");
    my ($i, $len);
    exists $sections{$current_section} || return;
    my $spaces = " " x 40;
    my $words_in_line = 0;  # New line when this goes to three
    my $man;
    foreach $man (@{$sections{$current_section}}) {
        $text->insert ("end", $man . substr ($spaces, 0, 24 - length ($man)));
        if (++$words_in_line == 3) {
            $text->insert ("end", "\n");
            $words_in_line = 0;
	    }
	}
    } #show_section_contents 

sub search
{
    my $search_pattern = $search->get ();
    $text->tagDelete ("search");
    $text->tagConfigure ("search", 
	-background => "Red4", 
	-foreground => "Yellow");

    my $current = "1.0";
    my $length = "0";
    my @tags;
    while (1) {
        if ($ignore_case) {
            $current = $text->search (
		-count => \$length,
		$match_type, 
		"-nocase",
		"--",
		$search_pattern,
		$current,
		"end");
	    }
	else {
            $current = $text->search (
		-count => \$length,
		$match_type, 
		"--",
		$search_pattern,
		$current,
		"end");
	    }
        $current || last;
        push @tags, $current;
        $text->tagAdd ("search", $current, "$current + $length char");
        $current = $text->index ("$current + $length char");
	}
    my $searchIndex = 0;
    $text->see ($tags[0]);
    $nextSearch->configure (
	-command => sub {
	    @tags &&
		$text->see ($tags[++$searchIndex % scalar @tags]);
	    });
    $prevSearch->configure (
	-command => sub {
	    @tags &&
		$text->see ($tags[(@tags + --$searchIndex) % scalar @tags]);
	    });
    } # search

sub scan_man_dirs
{
    my (@man_dirs, $man_dir, $section, $section_dir, $file, $page);

    if ($ENV{"MANPATH"}) {
        @man_dirs = split m/:/, $ENV{"MANPATH"};
	}
    else {
        push (@man_dirs, "/usr/man");
	}

    my %manfiles;
    tie %manfiles, "GDBM_File", "/tmp/w.2man.manfiles", O_RDWR | O_CREAT, 0666;
    my %sectlist;
    tie %sectlist, "GDBM_File", "/tmp/w.2man.sectlist", O_RDWR | O_CREAT, 0666;

    if (exists $manfiles{"/usr/share/man/man1.Z/man.1"} ||	# HP-UX 10.20
        exists $manfiles{"/usr/man/man1/man.1.gz"}		# DEC Alpha OSF/1
        ) {
	print STDERR "Man pages are cached\n";
	foreach my $fullpath (keys %manfiles) {
	    ($man_dir, $section_dir, $file) =
		($fullpath =~ m:(.*)/([^/]+)/([^/]+)$:);
	    ($page = $file) =~ s/\.(\d+\w?)(\.(Z|gz))?$//;
	    push @{$manfile{"$page($1)"}}, $fullpath;
	    push @{$manfile{$page}}, $fullpath;
	    push @{$manfile{$file}}, $fullpath;
	    }
        foreach $section (keys %sectlist) {
	    $sections{$section} = [ split m:/:, $sectlist{$section} ];
	    }
	untie %manfiles;
	untie %sectlist;
	return;
	}

    print STDERR "Scanning man directories\n";
    # Convert all relative man paths to fully qualified ones, by
    # prepending with $cwd
    my $cwd = cwd ();
    foreach (@man_dirs) {
	m:^/: || s:^:$cwd/:; # Modifies entry in man_dirs
	}
    foreach $man_dir (@man_dirs) {
	chdir $man_dir || next;
	# Now, in /usr/man, say. Get all the directories
	my @section_dirs = grep {-d $_} <man*>;
	# @section_dirs has cat1, cat1.Z, man1, man1n, man2, man3s etc.
	foreach $section_dir (@section_dirs) {
	    chdir $section_dir || next;
	    ($section = $section_dir) =~ s/^man//;
	    local *DIR;
	    opendir DIR, ".";
	    foreach $file (grep -f $_ && -s _ && m/\.\d/, readdir DIR) {
		my $fullpath = "$man_dir/$section_dir/$file";
		push @{$sections{$section}}, $file;
		($page = $file) =~ s/\.(\d+\w?)(\.(Z|gz))?$//;
		push @{$manfile{"$page($1)"}}, $fullpath;
		push @{$manfile{$page}}, $fullpath;
		push @{$manfile{$file}}, $fullpath;
		$manfiles{$fullpath} = $file;
		}
	    closedir DIR;
	    chdir "..";
	    }
	chdir "..";
	}
    # All sections in all man pages have been slurped in. Remove duplicates
    foreach $section (keys %sections) {
        my @new_list;
        my %seen;
        @new_list = sort (grep (!$seen{$_}++, @{$sections{$section}}));
        # Change all entries like cc.1 to cc(1)
        foreach (@new_list) {
            $_ =~ s/[.](.*)/($section)/;
	    }
        $sections{$section} = \@new_list;
        $sectlist{$section} = join "/", @new_list;
	}
    untie %manfiles;
    untie %sectlist;
    } # scan_man_dir