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

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