--- /dev/null
+# -*-perl-*-
+#
+# $Id: SWMan.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
+#
+# Display and other fiddling of manual pages
+#
+# (c) 1999 EBI
+#
+
+#----- Licensing notice -----------------------------------------------------
+#
+# This file is part of sw-tools.
+#
+# sw-tools is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# sw-tools is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with sw-tools; if not, write to the Free Software Foundation,
+# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+#----- Revision history -----------------------------------------------------
+#
+# $Log: SWMan.pm,v $
+# Revision 1.1 1999/07/30 18:46:37 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package preamble -----------------------------------------------------
+
+package SWMan;
+
+use IO;
+use POSIX;
+use DirHandle;
+use Exporter;
+
+use SWConfig;
+use SWCGI qw(:DEFAULT :layout);
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(subst check);
+
+#----- Useful functions -----------------------------------------------------
+
+%mandb = ();
+
+# --- @mans(SECTION)@ ---
+#
+# Returns a reference to a list of manual pages in the given section.
+
+sub mans($) {
+ my ($sec) = @_;
+ $mandb{$sec} and return $mandb{sec};
+
+ my $d = DirHandle->new("$C{prefix}/man/man$sec") or return undef;
+ my @f;
+ while (my $f = $d->read()) {
+ push(@f, $f);
+ }
+ $mandb{$sec} = \@f;
+ return \@f;
+}
+
+# --- @check(NAME, SECTION)@ ---
+#
+# See whether there's a manpage called NAME with section SECTION.
+
+sub check($$) {
+ my $pre = "$C{prefix}/man/man";
+ my ($man, $sec) = @_;
+ my $f;
+
+ # --- Quick check for obvious things ---
+
+ my ($base) = ($sec =~ /^(\d+)/);
+ $f = "$pre$base/$man.$sec";
+ -r $f and return $f; $f .= ".gz"; -r $f and return $f;
+
+ # --- Snarf the appropriate filename list ---
+
+ my $fs = mans($base) or return undef;
+ foreach my $f (@$fs) {
+ $f =~ /^$man\.$sec\w+(\.gz)?$/ and return "$C{prefix}/man/man$base/$f";
+ }
+ return undef;
+}
+
+# --- @subst(STRING, NAME, SECTION)@ ---
+#
+# If NAME(SECTION) is a manual page, return the STRING appropriately wrapped
+# in an anchor element; otherwise return it unmolested.
+
+sub subst($$$) {
+ my ($s, $n, $sec) = @_;
+ check($n, $sec) and
+ return "<a href=\"$ref?act=man&man=$n&sec=$sec\">$s</a>";
+ return "$s";
+}
+
+# --- @sections()@ ---
+#
+# Return a list of manual sections.
+
+@sectionlist = ();
+
+sub sections() {
+ return @sectionlist if @sectionlist;
+ my @s = ();
+ my $d = DirHandle->new("$C{prefix}/man") or
+ barf("couldn't open man directory: $!");
+ while ($f = $d->read()) {
+ next if $f !~ /^man/ || !-d "$C{prefix}/man/$f";
+ push(@s, $');
+ }
+ return (@sectionlist = sort(@s));
+}
+
+#----- Display a quick section index ----------------------------------------
+
+sub quickie {
+ print "Quick section index:\n";
+ foreach $s (sections()) {
+ print "<a href=\"$ref?act=man&sec=$s\">$s</a>\n";
+ }
+}
+
+#----- Display indices for manual sections ----------------------------------
+
+sub dosection($) {
+ my ($sec) = @_;
+ my @m = ();
+
+ barf("illegal section `$sec'") if $sec =~ m:/:;
+
+ # --- Snarf the list of manual pages in this section ---
+
+ {
+ my $d = DirHandle->new("$C{prefix}/man/man$sec") or
+ barf("couldn't read directory `$C{prefix}/man/man$sec': $!");
+ while (my $f = $d->read()) {
+ my ($man, $sec) = split(/\./, $f, 3);
+ push(@m, "$man($sec)") if $sec;
+ }
+ }
+
+ # --- Sort and emit the index ---
+
+ print("<h4>Section $sec</h4>\n<table>");
+
+ {
+ my $col = 0;
+ foreach my $m (sort(@m)) {
+ my ($man, $sec) = $m =~ /^(.*)\((.*)\)$/;
+ $col or print("<tr>\n");
+ print("<td><a href=\"$ref?act=man&man=$man&sec=$sec\">$m</a>\n");
+ $col = ($col + 1) % 5;
+ }
+ }
+
+ print("</table>\n");
+}
+
+sub section {
+ my $sec = $Q{"sec"};
+ header("Index of manual section $sec");
+ quickie(); print "<hr>\n";
+ dosection($sec);
+ print "<hr>\n"; quickie();;
+ footer();
+}
+
+sub index {
+ header("Manual page index");
+ print("<h3>Manual page index</h3>\n");
+ foreach my $s (sections()) { dosection($s); }
+ footer();
+}
+
+#----- Display a manual page ------------------------------------------------
+
+sub man {
+ my ($man, $sec) = ($Q{"man"}, $Q{"sec"});
+
+ $sec or &index(), return;
+ $man or §ion(), return;
+
+ my $file = check($man, $sec) or
+ barf("no manual page $man($sec)");
+ barf("illegal filename `$file'") if $file =~ m:\./:;
+
+ # --- Read the manual page ---
+
+ my $p = IO::Pipe->new();
+ my $kid = fork();
+ defined($kid) or barf("fork failed: $!");
+ if ($kid == 0) {
+ $p->writer();
+ dup2($p->fileno(), 1);
+ chdir("$C{prefix}/man");
+ if ($file =~ /\.gz$/) {
+ $pp = IO::Pipe->new;
+ $kkid = fork();
+ defined($kid) or exit(127);
+ if ($kkid == 0) {
+ $pp->writer();
+ dup2($pp->fileno, 1);
+ exec("gzip", "-dc", $file);
+ exit(127);
+ }
+ exec("nroff", "-man");
+ } else {
+ exec("nroff", "-man", $file);
+ }
+ exit(127);
+ }
+ $p->reader();
+
+ # --- Spit out the manual page now ---
+
+ header("Manual page $Q{man}($Q{sec})");
+ quickie(); print "<hr>\n";
+ print "<pre>\n";
+ while (my $line = $p->getline()) {
+ chomp $line;
+
+ # --- Grind through the line turning it into HTML ---
+
+ {
+ my $state = "";
+ my $l = "";
+
+ for (my $i = 0; $i < length($line); $i++) {
+ my $ch = substr($line, $i, 1);
+ my $nstate = "";
+
+ # --- Sort out overstriking ---
+
+ if (substr($line, $i + 1, 1) eq "\b") {
+ my ($italic, $bold) = (0, 0);
+ $ch eq "_" and $italic = 1;
+ $ch eq substr($line, $i + 2, 1) and $bold = 1;
+ $ch = substr($line, $i + 2, 1);
+ while (substr($line, $i + 1, 1) eq "\b") { $i += 2; }
+ if ($italic && $bold) {
+ $nstate = $state ? $state : "b";
+ } elsif ($italic) {
+ $nstate = "i";
+ } elsif ($bold) {
+ $nstate = "b";
+ }
+ }
+ $state ne $nstate and
+ $l .= ($state && "</$state>") . ($nstate && "<$nstate>");
+ $state = $nstate;
+
+ # --- Translate the character if it's magical ---
+
+ $ch eq "&" and $ch = "&";
+ $ch eq "<" and $ch = "<";
+ $ch eq ">" and $ch = ">";
+ $l .= $ch;
+ }
+ $state and $l .= "</$state>";
+
+ # --- Now find manual references in there ---
+ #
+ # I don't use /x regexps very often, but I think this is a good excuse.
+
+ $l =~ s! ((?:\<[bi]\>)*) # Leading highlighting tags
+ ([-_.\w]+) # Various plausible manual name chars
+ ((?:\</[bi]\>)* # Closing highlighting tags
+ (?:\<[bi]\>)* # And opening ones again
+ \( # An open parenthesis
+ (?:\<[bi]\>)*) # More opening highlights
+ (\d+\w*) # The section number
+ ((?:\</[bi]\>)* # Close highlights
+ \) # Close parens
+ (?:\</[bi]\>)*) # Finally more closing tags
+ ! subst($&, $2, $4) !egx;
+
+ # --- And email and hypertext references too ---
+
+ $l =~ s! ((?:\<[bi]\>)*) # Leading highlighting
+ ((?:http|ftp) # A protocol name
+ :// # The important and obvious bit
+ [^]&)\s]+ # Most characters are allowed
+ [^]&).,\s\'\"]) # Don't end on punctuation
+ ((?:\</[bi]\>)*) # Closing tags, optional
+ !<a href="$2">$&</a>!gx;
+
+ $l =~ s! ((?:\<[bi]\>)*)
+ ( [^\s()&;{}<>,.\`\"] [^\s()&;{}<>\`\"]* \@
+ [^\s()&;{}<>\'\"]* [^\s()&;{}<>.,\'\"])
+ ((?:\</[bi]\>)*)
+ !<a href="mailto:$2">$&</a>!gx;
+
+ # --- Done! ---
+
+ print $l, "\n";
+ }
+ }
+
+ # --- Done all of that ---
+
+ print "</pre>\n";
+ $p->close();
+ waitpid($kid, 0);
+ barf("nroff failed (exit status $?)") if $?;
+ print "<hr>\n"; quickie();;
+ footer();
+}
+
+#----- Register actions -----------------------------------------------------
+
+$main::ACT{"man"} = \&man;
+
+#----- That's all, folks ----------------------------------------------------
+
+1;
~mdw / sw-tools / blobdiff