| 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 `&'. 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/\&\;/&/; |
| 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 §ion(), 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 = "&"; |
| 289 | $ch eq "<" and $ch = "<<"; |
| 290 | $ch eq ">" and $ch = ">>"; |
| 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/\<\;\</</g; |
| 330 | $l =~ s/\>\>\;/>/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; |