Slight improvements to URL and email address parsing.

[sw-tools] / perl / SWDoc.pm

# -*-perl-*-
#
# $Id: SWDoc.pm,v 1.2 1999/08/18 17:10:07 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.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;
    $line =~ s!\b(https?|ftp|file|news):[^]&)\s]*[^]&).,\s\']!<a href="$&">$&</a>!g;
    $line =~ s!info:([^]&)\s]*[^]&).,\s\'\"])!<a href="$ref?act=info&file=$1&node=Top">$&</a>!g;
    $line =~ s!(?:\bmailto:)?([^\s()&;:{}.,\`\"][^\s()&;:{}\`\"]*\@[^\s()&;:{}\'\"]*[^\s()&;:{}.,\'\"])!<a href="mailto:$1">$&</a>!g;
    $line =~ s!([-_.\w]+)\((\d+\w*)\)!SWMan::subst("$1($2)", $1, $2)!eg;
    print $line;
  }
  print "</pre>\n";
  footer();
}

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

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

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

1;