[sw-tools] / perl / SWMan.pm

# -*-perl-*-
#
# $Id: SWMan.pm,v 1.4 1999/08/24 12:15:34 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.4  1999/08/24 12:15:34  mdw
# Properly sanitize CGI arguments (like `gtk+').
#
# Revision 1.3  1999/08/19 12:11:10  mdw
# More improvements to URL recognizer.
#
# Revision 1.2  1999/08/18 17:10:07  mdw
# Slight improvements to URL and email address parsing.
#
# 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 urlsubst 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 sprintf("<a href=\"$ref?act=man&man=%s&sec=$sec\">$s</a>",
		   SWCGI::sanitize($n));
  return $s;
}

# --- @urlsubst(URL, STRING)@ ---
#
# Substitutes in a URL reference.  The important bit is that embedded `&'
# characters are un-entitied from `&amp;'.  This doesn't seem to upset
# Netscape or Lynx as much as I'd expect (or, in fact, at all), but it's
# slightly untidy.

sub urlsubst($$) {
  my ($url, $name) = @_;
  $url =~ s/\&amp\;/&/;
  return "<a href=\"$url\">$name</a>";
}

# --- @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 &section(), 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 = "&amp;";
	$ch eq "<" and $ch = "&lt;<";
	$ch eq ">" and $ch = ">&gt;";
	$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
	       ( \b (?: http s? | ftp | file | news ) # A protocol name
		:			# The important and obvious bit
		[^]<>)\s<>\'\"]+	# Most characters are allowed
		[^]<>).,\s<>\'\"])	# Don't end on punctuation
  	       ((?:\</[bi]\>)*)		# Closing tags, optional
  	     !urlsubst($2, $&)!egx;

      $l =~ s! ( (?:\<[bi]\>)* (?:\bmailto:)? )
               ( [^\s()<>;:{}&<>,.\`\'\"] [^\s()<>;:{}&<>\`\'\"]* \@
                 [^\s()<>;:{&}<>\'\"]* [^\s()<>;:{}&<>.,\'\"])
               ((?:\</[bi]\>)*)
             !<a href="mailto:$2">$&</a>!gx;

      # --- Fix up the HTML ---

      $l =~ s/\&lt\;\</&lt;/g;
      $l =~ s/\>\&gt\;/&gt;/g;

      # --- 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;
Commit	Line	Data
961ce1c2	1	# --perl--
961ce1c2	2	#
fef14233	3	# $Id: SWMan.pm,v 1.4 1999/08/24 12:15:34 mdw Exp $
961ce1c2	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 $
fef14233	31	# Revision 1.4 1999/08/24 12:15:34 mdw
	32	# Properly sanitize CGI arguments (like `gtk+').
	33	#
fae2108b	34	# Revision 1.3 1999/08/19 12:11:10 mdw
	35	# More improvements to URL recognizer.
	36	#
44b3c589	37	# Revision 1.2 1999/08/18 17:10:07 mdw
	38	# Slight improvements to URL and email address parsing.
	39	#
961ce1c2	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);
fae2108b	57	@EXPORT_OK = qw(subst urlsubst check);
961ce1c2	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
fef14233	112	return sprintf("<a href=\"$ref?act=man&man=%s&sec=$sec\">$s</a>",
	113	SWCGI::sanitize($n));
	114	return $s;
961ce1c2	115	}
961ce1c2	116
fae2108b	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/\&amp\;/&/;
	127	return "<a href=\"$url\">$name</a>";
	128	}
	129
961ce1c2	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 = "&";
fae2108b	289	$ch eq "<" and $ch = "<<";
fae2108b	290	$ch eq ">" and $ch = ">>";
961ce1c2	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
fae2108b	314	( \b (?: http s? \| ftp \| file \| news ) # A protocol name
44b3c589	315	: # The important and obvious bit
fae2108b	316	[^]<>)\s<>\'\"]+ # Most characters are allowed
fae2108b	317	[^]<>).,\s<>\'\"]) # Don't end on punctuation
961ce1c2	318	((?:\</[bi]\>)*) # Closing tags, optional
fae2108b	319	!urlsubst($2, $&)!egx;
961ce1c2	320
fae2108b	321	$l =~ s! ( (?:\<[bi]\>)* (?:\bmailto:)? )
	322	( [^\s()<>;:{}&<>,.\`\'\"] [^\s()<>;:{}&<>\`\'\"]* \@
	323	[^\s()<>;:{&}<>\'\"]* [^\s()<>;:{}&<>.,\'\"])
961ce1c2	324	((?:\</[bi]\>)*)
fae2108b	325	!<a href="mailto:$2">$&</a>!gx;
	326
	327	# --- Fix up the HTML ---
	328
	329	$l =~ s/\&lt\;\</</g;
	330	$l =~ s/\>\&gt\;/>/g;
961ce1c2	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;