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

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