chiark - git - mdw - sw-tools/blob - perl/SWMan.pm

   1 # -*-perl-*-
   2 #
   3 # $Id: SWMan.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
   4 #
   5 # Display and other fiddling of manual pages
   6 #
   7 # (c) 1999 EBI
   8 #
   9
  10 #----- Licensing notice -----------------------------------------------------
  11 #
  12 # This file is part of sw-tools.
  13 #
  14 # sw-tools is free software; you can redistribute it and/or modify
  15 # it under the terms of the GNU General Public License as published by
  16 # the Free Software Foundation; either version 2 of the License, or
  17 # (at your option) any later version.
  18 #
  19 # sw-tools is distributed in the hope that it will be useful,
  20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 # GNU General Public License for more details.
  23 #
  24 # You should have received a copy of the GNU General Public License
  25 # along with sw-tools; if not, write to the Free Software Foundation,
  26 # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  27
  28 #----- Revision history -----------------------------------------------------
  29 #
  30 # $Log: SWMan.pm,v $
  31 # Revision 1.1  1999/07/30 18:46:37  mdw
  32 # New CGI script for browsing installed software and documentation.
  33 #
  34
  35 #----- Package preamble -----------------------------------------------------
  36
  37 package SWMan;
  38
  39 use IO;
  40 use POSIX;
  41 use DirHandle;
  42 use Exporter;
  43
  44 use SWConfig;
  45 use SWCGI qw(:DEFAULT :layout);
  46
  47 @ISA = qw(Exporter);
  48 @EXPORT_OK = qw(subst check);
  49
  50 #----- Useful functions -----------------------------------------------------
  51
  52 %mandb = ();
  53
  54 # --- @mans(SECTION)@ ---
  55 #
  56 # Returns a reference to a list of manual pages in the given section.
  57
  58 sub mans($) {
  59   my ($sec) = @_;
  60   $mandb{$sec} and return $mandb{sec};
  61
  62   my $d = DirHandle->new("$C{prefix}/man/man$sec") or return undef;
  63   my @f;
  64   while (my $f = $d->read()) {
  65     push(@f, $f);
  66   }
  67   $mandb{$sec} = \@f;
  68   return \@f;
  69 }
  70
  71 # --- @check(NAME, SECTION)@ ---
  72 #
  73 # See whether there's a manpage called NAME with section SECTION.
  74
  75 sub check($$) {
  76   my $pre = "$C{prefix}/man/man";
  77   my ($man, $sec) = @_;
  78   my $f;
  79
  80   # --- Quick check for obvious things ---
  81
  82   my ($base) = ($sec =~ /^(\d+)/);
  83   $f = "$pre$base/$man.$sec";
  84   -r $f and return $f; $f .= ".gz"; -r $f and return $f;
  85
  86   # --- Snarf the appropriate filename list ---
  87
  88   my $fs = mans($base) or return undef;
  89   foreach my $f (@$fs) {
  90     $f =~ /^$man\.$sec\w+(\.gz)?$/ and return "$C{prefix}/man/man$base/$f";
  91   }
  92   return undef;
  93 }
  94
  95 # --- @subst(STRING, NAME, SECTION)@ ---
  96 #
  97 # If NAME(SECTION) is a manual page, return the STRING appropriately wrapped
  98 # in an anchor element; otherwise return it unmolested.
  99
 100 sub subst($$$) {
 101   my ($s, $n, $sec) = @_;
 102   check($n, $sec) and
 103     return "<a href=\"$ref?act=man&man=$n&sec=$sec\">$s</a>";
 104   return "$s";
 105 }
 106
 107 # --- @sections()@ ---
 108 #
 109 # Return a list of manual sections.
 110
 111 @sectionlist = ();
 112
 113 sub sections() {
 114   return @sectionlist if @sectionlist;
 115   my @s = ();
 116   my $d = DirHandle->new("$C{prefix}/man") or
 117     barf("couldn't open man directory: $!");
 118   while ($f = $d->read()) {
 119     next if $f !~ /^man/ || !-d "$C{prefix}/man/$f";
 120     push(@s, $');
 121   }
 122   return (@sectionlist = sort(@s));
 123 }
 124
 125 #----- Display a quick section index ----------------------------------------
 126
 127 sub quickie {
 128   print "Quick section index:\n";
 129   foreach $s (sections()) {
 130     print "<a href=\"$ref?act=man&sec=$s\">$s</a>\n";
 131   }
 132 }
 133
 134 #----- Display indices for manual sections ----------------------------------
 135
 136 sub dosection($) {
 137   my ($sec) = @_;
 138   my @m = ();
 139
 140   barf("illegal section `$sec'") if $sec =~ m:/:;
 141
 142   # --- Snarf the list of manual pages in this section ---
 143
 144   {
 145     my $d = DirHandle->new("$C{prefix}/man/man$sec") or
 146       barf("couldn't read directory `$C{prefix}/man/man$sec': $!");
 147     while (my $f = $d->read()) {
 148       my ($man, $sec) = split(/\./, $f, 3);
 149       push(@m, "$man($sec)") if $sec;
 150     }
 151   }
 152
 153   # --- Sort and emit the index ---
 154
 155   print("<h4>Section $sec</h4>\n<table>");
 156
 157   {
 158     my $col = 0;
 159     foreach my $m (sort(@m)) {
 160       my ($man, $sec) = $m =~ /^(.*)\((.*)\)$/;
 161       $col or print("<tr>\n");
 162       print("<td><a href=\"$ref?act=man&man=$man&sec=$sec\">$m</a>\n");
 163       $col = ($col + 1) % 5;
 164     }
 165   }
 166
 167   print("</table>\n");
 168 }
 169
 170 sub section {
 171   my $sec = $Q{"sec"};
 172   header("Index of manual section $sec");
 173   quickie(); print "<hr>\n";
 174   dosection($sec);
 175   print "<hr>\n"; quickie();;
 176   footer();
 177 }
 178
 179 sub index {
 180   header("Manual page index");
 181   print("<h3>Manual page index</h3>\n");
 182   foreach my $s (sections()) { dosection($s); }
 183   footer();
 184 }
 185
 186 #----- Display a manual page ------------------------------------------------
 187
 188 sub man {
 189   my ($man, $sec) = ($Q{"man"}, $Q{"sec"});
 190
 191   $sec or &index(), return;
 192   $man or &section(), return;
 193
 194   my $file = check($man, $sec) or
 195     barf("no manual page $man($sec)");
 196   barf("illegal filename `$file'") if $file =~ m:\./:;
 197
 198   # --- Read the manual page ---
 199
 200   my $p = IO::Pipe->new();
 201   my $kid = fork();
 202   defined($kid) or barf("fork failed: $!");
 203   if ($kid == 0) {
 204     $p->writer();
 205     dup2($p->fileno(), 1);
 206     chdir("$C{prefix}/man");
 207     if ($file =~ /\.gz$/) {
 208       $pp = IO::Pipe->new;
 209       $kkid = fork();
 210       defined($kid) or exit(127);
 211       if ($kkid == 0) {
 212         $pp->writer();
 213         dup2($pp->fileno, 1);
 214         exec("gzip", "-dc", $file);
 215         exit(127);
 216       }
 217       exec("nroff", "-man");
 218     } else {
 219       exec("nroff", "-man", $file);
 220     }
 221     exit(127);
 222   }
 223   $p->reader();
 224
 225   # --- Spit out the manual page now ---
 226
 227   header("Manual page $Q{man}($Q{sec})");
 228   quickie(); print "<hr>\n";
 229   print "<pre>\n";
 230   while (my $line = $p->getline()) {
 231     chomp $line;
 232
 233     # --- Grind through the line turning it into HTML ---
 234
 235     {
 236       my $state = "";
 237       my $l = "";
 238
 239       for (my $i = 0; $i < length($line); $i++) {
 240         my $ch = substr($line, $i, 1);
 241         my $nstate = "";
 242
 243         # --- Sort out overstriking ---
 244
 245         if (substr($line, $i + 1, 1) eq "\b") {
 246           my ($italic, $bold) = (0, 0);
 247           $ch eq "_" and $italic = 1;
 248           $ch eq substr($line, $i + 2, 1) and $bold = 1;
 249           $ch = substr($line, $i + 2, 1);
 250           while (substr($line, $i + 1, 1) eq "\b") { $i += 2; }
 251           if ($italic && $bold) {
 252             $nstate = $state ? $state : "b";
 253           } elsif ($italic) {
 254             $nstate = "i";
 255           } elsif ($bold) {
 256             $nstate = "b";
 257           }
 258         }
 259         $state ne $nstate and
 260           $l .= ($state && "</$state>") . ($nstate && "<$nstate>");
 261         $state = $nstate;
 262
 263         # --- Translate the character if it's magical ---
 264
 265         $ch eq "&" and $ch = "&amp;";
 266         $ch eq "<" and $ch = "&lt;";
 267         $ch eq ">" and $ch = "&gt;";
 268         $l .= $ch;
 269       }
 270       $state and $l .= "</$state>";
 271
 272       # --- Now find manual references in there ---
 273       #
 274       # I don't use /x regexps very often, but I think this is a good excuse.
 275
 276       $l =~ s! ((?:\<[bi]\>)*)          # Leading highlighting tags
 277                ([-_.\w]+)               # Various plausible manual name chars
 278                ((?:\</[bi]\>)*          # Closing highlighting tags
 279                 (?:\<[bi]\>)*           # And opening ones again
 280                 \(                      # An open parenthesis
 281                 (?:\<[bi]\>)*)          # More opening highlights
 282                 (\d+\w*)                # The section number
 283                 ((?:\</[bi]\>)*         # Close highlights
 284                  \)                     # Close parens
 285                  (?:\</[bi]\>)*)        # Finally more closing tags
 286              ! subst($&, $2, $4) !egx;
 287
 288       # --- And email and hypertext references too ---
 289
 290       $l =~ s! ((?:\<[bi]\>)*)          # Leading highlighting
 291                ((?:http|ftp)            # A protocol name
 292                 ://                     # The important and obvious bit
 293                 [^]&)\s]+               # Most characters are allowed
 294                 [^]&).,\s\'\"])         # Don't end on punctuation
 295                ((?:\</[bi]\>)*)         # Closing tags, optional
 296              !<a href="$2">$&</a>!gx;
 297
 298       $l =~ s! ((?:\<[bi]\>)*)
 299                ( [^\s()&;{}<>,.\`\"] [^\s()&;{}<>\`\"]* \@
 300                  [^\s()&;{}<>\'\"]* [^\s()&;{}<>.,\'\"])
 301                ((?:\</[bi]\>)*)
 302              !<a href="mailto:$2">$&</a>!gx;
 303
 304       # --- Done! ---
 305
 306       print $l, "\n";
 307     }
 308   }
 309
 310   # --- Done all of that ---
 311
 312   print "</pre>\n";
 313   $p->close();
 314   waitpid($kid, 0);
 315   barf("nroff failed (exit status $?)") if $?;
 316   print "<hr>\n"; quickie();;
 317   footer();
 318 }
 319
 320 #----- Register actions -----------------------------------------------------
 321
 322 $main::ACT{"man"} = \&man;
 323
 324 #----- That's all, folks ----------------------------------------------------
 325
 326 1;