#!/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

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.