#!/usr/bin/perl
#-------------------------------------
# perlman: perldoc pod/man page viewer
#-------------------------------------
# Adapted (very loosely) by David Graff, from example code that came
# with a perl-Tk distribution.
#
# version 1.0, 4-May-1999
# version 2.0, 20-Sep-2002: adapted to handle user-selected perl version properly
# (basically, the pod/man pages you get depend on which version of perl you use
# to run the app; very handy on systems where more than one version is installed

use strict;
use Tk;

my ($perlbase) = grep m%lib%, @INC;
$perlbase =~ s%/lib.*%%;
my $perldoc = "$perlbase/bin/perldoc";	# /path/name of perldoc to show man and pod pages

scout_man_dirs();
create_ui();
MainLoop();

#-------------------------------------------------------------------
my $showEntry;       # for user to type in a doc name to "Show"
my $searchEntry;     # for user to type in a string pattern to "Search" for
my $fullListbox;     # presents complete list of perl man page names
my $srchListbox;     # presents search-matched list of perl man page names
my %doclist;         # hash lookup for man page file paths, keyed by man page name
my $docnames;        # sorted concatenation of man page names
my @docnames;        # sorted array of man page names

sub show_man {
    my $entry = $showEntry->get();   # get entry from $show

    if ( $docnames =~ / ($entry) /i || $docnames =~ / (\w+\:+$entry) /i ) {
        $entry = $1;
    }
    system( "xterm -geometry 85x45 -T '$entry' -n '$entry' -e $perldoc $entry &" );
}
sub print_man {
    my $entry = $showEntry->get();   # get entry from $show

    if ( $docnames =~ / ($entry) /i || $docnames =~ / (\w+\:+$entry) /i ) {
        $entry = $1;
    }
    system( "$perldoc $entry | enscript -2rl 2> /dev/null" );
}

sub create_ui {
    my $mainWin = MainWindow->new();
    $mainWin->title("Perl Documentation");
    my $topFrame = $mainWin->Frame()->pack(-side => 'top', -fill => 'x');
    my $cntlFrame = $mainWin->Frame()->pack(-side => 'top', -fill => 'x');
    my $listFrame = $mainWin->Frame()->pack(-side => 'top', -fill => 'x');

    $topFrame->Label(-text => "POD/MAN page index for Perl $]")->pack(-side => 'left');
    $topFrame->Button(-text => 'Reload',
                      -command => \&scout_man_dirs )->pack(-side => 'left');
    $topFrame->Button(-text => 'Exit',
                      -command => \&exit )->pack(-side => 'left', -padx => 5);

    $cntlFrame->Label(-text => 'Show:')->pack(-side => 'left', -padx => 5);
    $showEntry = $cntlFrame->Entry (-width => 15)->pack(-side => 'left');
    $showEntry->bind('<KeyPress-Return>', \&show_man);

    $cntlFrame->Button(-text => 'Print',
                       -command => \&print_man )->pack(-side => 'left', -padx => 5);

    $cntlFrame->Label(-text => 'Search:')->pack(-side => 'left', -padx => 5);
    $searchEntry = $cntlFrame->Entry (-width => 15)->pack(-side => 'left');
    $searchEntry->bind('<KeyPress-Return>', \&search);


    $fullListbox = $listFrame->Scrolled('Listbox',
                                        -scrollbars => 'oe',
                                        -width =>  25, 
                                        -height => 20)->pack(-side => 'left');
    $srchListbox = $listFrame->Scrolled('Listbox',
                                        -scrollbars => 'oe',
                                        -width =>  25, 
                                        -height => 20)->pack(-side => 'left');

    $fullListbox->insert( "end", @docnames );

    $mainWin->bind('Tk::Listbox', '<Double-1>', \&pick_word);
}

sub pick_word {
    my( $lw ) = @_;
    my $mname = $lw->get( $lw->curselection );
    $showEntry->delete( 0, "end" );
    $showEntry->insert( 0, $mname );
    show_man();
}

sub search {
    my $search_pattern = $searchEntry->get();
    my @search_matches = grep( /$search_pattern/i, @docnames );

    $srchListbox->delete( 0, "end" );
    if ( $#search_matches < 0 ) {
        $srchListbox->insert( "end", "No matches for $search_pattern" );
    } else {
        $srchListbox->insert( "end", @search_matches );
    }
}

use File::Basename;
sub scout_man_dirs {
    my @man_files = `find $perlbase/man -name '*.[13]'`;
    my @suffixes = qw/.1 .3/;

    fileparse_set_fstype();
    foreach my $docpath ( @man_files )
    {
        chomp $docpath;
        my $docname = basename( $docpath, @suffixes );
        $doclist{$docname} = $docpath;
    }
    @docnames = sort( keys( %doclist ));
    $docnames = join( " ", "", @docnames, "" );
}