3 # $Id: SWMan.pm,v 1.5 2004/04/08 01:52:19 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 #----- Package preamble -----------------------------------------------------
38 use SWCGI
qw(:DEFAULT
:layout
);
41 @EXPORT_OK = qw(subst urlsubst check
);
43 #----- Useful functions -----------------------------------------------------
47 # --- @mans(SECTION)@ ---
49 # Returns a reference to a list of manual pages in the given section.
53 $mandb{$sec} and return $mandb{sec
};
55 my $d = DirHandle
->new("$C{prefix}/man/man$sec") or return undef;
57 while (my $f = $d->read()) {
64 # --- @check(NAME, SECTION)@ ---
66 # See whether there's a manpage called NAME with section SECTION.
69 my $pre = "$C{prefix}/man/man";
73 # --- Quick check for obvious things ---
75 my ($base) = ($sec =~ /^(\d+)/);
76 $f = "$pre$base/$man.$sec";
77 -r
$f and return $f; $f .= ".gz"; -r
$f and return $f;
79 # --- Snarf the appropriate filename list ---
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";
88 # --- @subst(STRING, NAME, SECTION)@ ---
90 # If NAME(SECTION) is a manual page, return the STRING appropriately wrapped
91 # in an anchor element; otherwise return it unmolested.
94 my ($s, $n, $sec) = @_;
96 return sprintf("<a href=\"$ref?act=man&man=%s&sec=$sec\">$s</a>",
101 # --- @urlsubst(URL, STRING)@ ---
103 # Substitutes in a URL reference. The important bit is that embedded `&'
104 # characters are un-entitied from `&'. This doesn't seem to upset
105 # Netscape or Lynx as much as I'd expect (or, in fact, at all), but it's
109 my ($url, $name) = @_;
110 $url =~ s/\&\;/&/;
111 return "<a href=\"$url\">$name</a>";
114 # --- @sections()@ ---
116 # Return a list of manual sections.
121 return @sectionlist if @sectionlist;
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";
129 return (@sectionlist = sort(@s));
132 #----- Display a quick section index ----------------------------------------
135 print "Quick section index:\n";
136 foreach $s (sections()) {
137 print "<a href=\"$ref?act=man&sec=$s\">$s</a>\n";
141 #----- Display indices for manual sections ----------------------------------
147 barf("illegal section `$sec'") if $sec =~ m:/:;
149 # --- Snarf the list of manual pages in this section ---
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;
160 # --- Sort and emit the index ---
162 print("<h4
>Section
$sec</h4
>\n<table
>");
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;
179 header("Index of manual section
$sec");
180 quickie(); print "<hr
>\n";
182 print "<hr
>\n"; quickie();;
187 header("Manual page
index");
188 print("<h3
>Manual page
index</h3
>\n");
189 foreach my $s (sections()) { dosection($s); }
193 #----- Display a manual page ------------------------------------------------
196 my ($man, $sec) = ($Q{"man
"}, $Q{"sec
"});
198 $sec or &index(), return;
199 $man or §ion(), return;
201 my $file = check($man, $sec) or
202 barf("no manual page
$man($sec)");
203 barf("illegal filename
`$file'") if $file =~ m:\./:;
205 # --- Read the manual page ---
207 my $p = IO::Pipe->new();
209 defined($kid) or barf("fork failed: $!");
212 dup2($p->fileno(), 1);
213 chdir("$C{prefix}/man");
214 if ($file =~ /\.gz$/) {
217 defined($kid) or exit(127);
220 dup2($pp->fileno, 1);
221 exec("gzip", "-dc", $file);
224 exec("nroff", "-man");
226 exec("nroff", "-man", $file);
232 # --- Spit out the manual page now ---
234 header("Manual page $Q{man}($Q{sec})");
235 quickie(); print "<hr>\n";
237 while (my $line = $p->getline()) {
240 # --- Grind through the line turning it into HTML ---
246 for (my $i = 0; $i < length($line); $i++) {
247 my $ch = substr($line, $i, 1);
250 # --- Sort out overstriking ---
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";
266 $state ne $nstate and
267 $l .= ($state && "</$state>") . ($nstate && "<$nstate>");
270 # --- Translate the character if it's magical ---
272 $ch eq "&" and $ch = "&";
273 $ch eq "<" and $ch = "<<";
274 $ch eq ">" and $ch = ">>";
277 $state and $l .= "</$state>";
279 # --- Now find manual references in there ---
281 # I don't use /x regexps very often, but I think this is a good excuse.
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
292 (?:\</[bi]\>)*) # Finally more closing tags
293 ! subst($&, $2, $4) !egx;
295 # --- And email and hypertext references too ---
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;
305 $l =~ s! ( (?:\<[bi]\>)* (?:\bmailto:)? )
306 ( [^\s()<>;:{}&<>,.\`\'\"] [^\s
()<>;:{}&<>\
`\'\"]* \@
307 [^\s()<>;:{&}<>\'\"]* [^\s()<>;:{}&<>.,\'\"])
309 !<a href="mailto:$2">$&</a>!gx;
311 # --- Fix up the HTML ---
313 $l =~ s/\<\;\</</g;
314 $l =~ s/\>\>\;/>/g;
322 # --- Done all of that ---
327 barf("nroff failed (exit status $?)") if $?;
328 print "<hr>\n"; quickie();;
332 #----- Register actions -----------------------------------------------------
334 $main::ACT{"man"} = \&man;
336 #----- That's all, folks ----------------------------------------------------