More improvements to URL recognizer.

[sw-tools] / perl / SWDoc.pm

# -*-perl-*-
#
# $Id: SWDoc.pm,v 1.3 1999/08/19 12:11:09 mdw Exp $
#
# Display documentation files
#
# (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: SWDoc.pm,v $
# Revision 1.3  1999/08/19 12:11:09  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 SWDoc;

use IO;
use POSIX;
use SWConfig;
use SWCGI qw(:DEFAULT :layout);
use SWMan;

#----- Actions provided -----------------------------------------------------

sub doc {
  my $file = "$C{doc}/$Q{pkg}";
  barf("illegal filename `$file'") if $file =~ m:\./:;
  my $fh = IO::File->new($file, O_RDONLY) or
    barf("couldn't open `$file': $!");
  header("Local documentation for package $Q{pkg}");
  print("<h3>Local documentation for package $Q{pkg}</h3>\n");
  print("<pre>\n");

  while (my $line = $fh->getline()) {
    last if $line =~ /\f/;
    $line =~ s/\&/&amp;/g;
    $line =~ s/\</&lt;</g;
    $line =~ s/\>/>&gt;/g;

    # --- Spot URLs (except `mailto') ---

    $line =~ s! \b (http s? | ftp | file | news) :
		[^])\s<>]* [^]<>&).,\s\']
	      !SWMan::urlsubst($&, $&)!egx;

    # --- Spot email addresses (including `mailto' URLs) ---

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

    # --- Spot info references ---

    $line =~ s! \b info: ([^]&)\s<>]* [^]&).,\s<>\'\"])
              !<a href="$ref?act=info&file=$1&node=Top">$&</a>!gx;

    # --- Spot manpage references ---

    $line =~ s! ([-_.\w]+) \( (\d+\w*) \)
	      !SWMan::subst("$1($2)", $1, $2)!egx;

    # --- Finally fix up the HTML properly ---

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

    print $line;
  }
  print "</pre>\n";
  footer();
}

#----- Register actions -----------------------------------------------------

$main::ACT{"doc"} = \&doc;

#----- That's all, folks ----------------------------------------------------

1;