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

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