3 # $Id: SWMan.pm,v 1.4 1999/08/24 12:15:34 mdw Exp $
5 # Display and other fiddling of manual pages
10 #----- Licensing notice -----------------------------------------------------
12 # This file is part of sw-tools.
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.
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.
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.
28 #----- Revision history -----------------------------------------------------
31 # Revision 1.4 1999/08/24 12:15:34 mdw
32 # Properly sanitize CGI arguments (like `gtk+').
34 # Revision 1.3 1999/08/19 12:11:10 mdw
35 # More improvements to URL recognizer.
37 # Revision 1.2 1999/08/18 17:10:07 mdw
38 # Slight improvements to URL and email address parsing.
40 # Revision 1.1 1999/07/30 18:46:37 mdw
41 # New CGI script for browsing installed software and documentation.
44 #----- Package preamble -----------------------------------------------------
54 use SWCGI
qw(:DEFAULT
:layout
);
57 @EXPORT_OK = qw(subst urlsubst check
);
59 #----- Useful functions -----------------------------------------------------
63 # --- @mans(SECTION)@ ---
65 # Returns a reference to a list of manual pages in the given section.
69 $mandb{$sec} and return $mandb{sec
};
71 my $d = DirHandle
->new("$C{prefix}/man/man$sec") or return undef;
73 while (my $f = $d->read()) {
80 # --- @check(NAME, SECTION)@ ---
82 # See whether there's a manpage called NAME with section SECTION.
85 my $pre = "$C{prefix}/man/man";
89 # --- Quick check for obvious things ---
91 my ($base) = ($sec =~ /^(\d+)/);
92 $f = "$pre$base/$man.$sec";
93 -r
$f and return $f; $f .= ".gz"; -r
$f and return $f;
95 # --- Snarf the appropriate filename list ---
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";
104 # --- @subst(STRING, NAME, SECTION)@ ---
106 # If NAME(SECTION) is a manual page, return the STRING appropriately wrapped
107 # in an anchor element; otherwise return it unmolested.
110 my ($s, $n, $sec) = @_;
112 return sprintf("<a href=\"$ref?act=man&man=%s&sec=$sec\">$s</a>",
113 SWCGI
::sanitize
($n));
117 # --- @urlsubst(URL, STRING)@ ---
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
125 my ($url, $name) = @_;
126 $url =~ s/\&\;/&/;
127 return "<a href=\"$url\">$name</a>";
130 # --- @sections()@ ---
132 # Return a list of manual sections.
137 return @sectionlist if @sectionlist;
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";
145 return (@sectionlist = sort(@s));
148 #----- Display a quick section index ----------------------------------------
151 print "Quick section index:\n";
152 foreach $s (sections()) {
153 print "<a href=\"$ref?act=man&sec=$s\">$s</a>\n";
157 #----- Display indices for manual sections ----------------------------------
163 barf("illegal section `$sec'") if $sec =~ m:/:;
165 # --- Snarf the list of manual pages in this section ---
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;
176 # --- Sort and emit the index ---
178 print("<h4
>Section
$sec</h4
>\n<table
>");
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;
195 header("Index of manual section
$sec");
196 quickie(); print "<hr
>\n";
198 print "<hr
>\n"; quickie();;
203 header("Manual page
index");
204 print("<h3
>Manual page
index</h3
>\n");
205 foreach my $s (sections()) { dosection($s); }
209 #----- Display a manual page ------------------------------------------------
212 my ($man, $sec) = ($Q{"man
"}, $Q{"sec
"});
214 $sec or &index(), return;
215 $man or §ion(), return;
217 my $file = check($man, $sec) or
218 barf("no manual page
$man($sec)");
219 barf("illegal filename
`$file'") if $file =~ m:\./:;
221 # --- Read the manual page ---
223 my $p = IO::Pipe->new();
225 defined($kid) or barf("fork failed: $!");
228 dup2($p->fileno(), 1);
229 chdir("$C{prefix}/man");
230 if ($file =~ /\.gz$/) {
233 defined($kid) or exit(127);
236 dup2($pp->fileno, 1);
237 exec("gzip", "-dc", $file);
240 exec("nroff", "-man");
242 exec("nroff", "-man", $file);
248 # --- Spit out the manual page now ---
250 header("Manual page $Q{man}($Q{sec})");
251 quickie(); print "<hr>\n";
253 while (my $line = $p->getline()) {
256 # --- Grind through the line turning it into HTML ---
262 for (my $i = 0; $i < length($line); $i++) {
263 my $ch = substr($line, $i, 1);
266 # --- Sort out overstriking ---
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";
282 $state ne $nstate and
283 $l .= ($state && "</$state>") . ($nstate && "<$nstate>");
286 # --- Translate the character if it's magical ---
288 $ch eq "&" and $ch = "&";
289 $ch eq "<" and $ch = "<<";
290 $ch eq ">" and $ch = ">>";
293 $state and $l .= "</$state>";
295 # --- Now find manual references in there ---
297 # I don't use /x regexps very often, but I think this is a good excuse.
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
308 (?:\</[bi]\>)*) # Finally more closing tags
309 ! subst($&, $2, $4) !egx;
311 # --- And email and hypertext references too ---
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;
321 $l =~ s! ( (?:\<[bi]\>)* (?:\bmailto:)? )
322 ( [^\s()<>;:{}&<>,.\`\'\"] [^\s
()<>;:{}&<>\
`\'\"]* \@
323 [^\s()<>;:{&}<>\'\"]* [^\s()<>;:{}&<>.,\'\"])
325 !<a href="mailto:$2">$&</a>!gx;
327 # --- Fix up the HTML ---
329 $l =~ s/\<\;\</</g;
330 $l =~ s/\>\>\;/>/g;
338 # --- Done all of that ---
343 barf("nroff failed (exit status $?)") if $?;
344 print "<hr>\n"; quickie();;
348 #----- Register actions -----------------------------------------------------
350 $main::ACT{"man"} = \&man;
352 #----- That's all, folks ----------------------------------------------------