More improvements to URL recognizer.

[sw-tools] / perl / SWInfo.pm

# -*-perl-*-
#
# $Id: SWInfo.pm,v 1.3 1999/08/19 12:11:10 mdw Exp $
#
# Read and output GNU Info 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: SWInfo.pm,v $
# 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 SWInfo;

use IO;

use SWConfig;
use SWCGI qw(:DEFAULT :layout);
use SWMan;
use Info;

#----- Useful functions -----------------------------------------------------

# --- @subst(IREF, FILE, INFO)@ ---
#
# Given an Info reference and the name of the current Info file, returns an
# HTML anchor which represents the link.

sub subst($$$) {
  my ($iref, $file, $i) = @_;
  my $node;
  my $dir;
  my $tail = "";

  # --- Dig out the node and file being referred to ---

  if ($iref =~ /:$/) {
    $tail = ":";
    $iref = $`;
  }
  my $oref = $iref;
  $iref =~ s/\s+/ /g;
  if ($iref =~ /^.+: *(.+)$/) { $iref = $1; }
  if ($iref =~ /(?:\(([^\)]*)\))?(.*)$/) {
    $file = $1 || $file;
    $node = $2 || "Top";
  } else {
    $node = $iref;
  }

  # --- Transform it into something that won't get mangled ---

  $node =~ s/[+&=%]|[^ -~]/sprintf("%%%02x", ord($&))/eg;
  $node =~ tr/ /+/;

  ($dir = $i->{dir}) =~ s:$C{prefix}/info/?::;
  $dir = "&dir=$dir" if $dir;

  return "<a href=\"$ref?act=info&file=$file&node=$node$dir\">$oref</a>$tail";
}

#----- Actions --------------------------------------------------------------

sub info {
  my $file = $Q{file} || "dir";
  my $node = $Q{node} || "Top";
  my $dir = $Q{dir} || "";
  my $out;

  # --- Read the node in ---

  Info::setpath("$C{prefix}/info");

  "$dir/$file" =~ m:\./: and
    barf("bad filename `$dir/$file'");
  my $i = (($dir && Info->new("$dir/$file")) ||
	   Info->new($file))
    or barf("couldn't find info file `$file'");
  my $n = $i->node($node) or
    barf("info file `$file' doesn't contain node `$node'");

  # --- Now translate the node into HTML, first line first ---

  $n =~ s/\&/&amp;/;
  $n =~ s/\</&lt;</;
  $n =~ s/\>/>&gt;/;
  $n =~ s/\A( [^\n]* Next:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
  $n =~ s/\A( [^\n]* Prev:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
  $n =~ s/\A( [^\n]* Up:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;

  # --- Grind through picking up any notes ---

  $out = "";

  for (;;) {
    if ($n =~ /(\*Note\s*)([^:]*: *(?:\([^\)]*\))?[^.,;:]*)([.,;:])/i) {
      $out .= $` . $1 . subst($2, $file, $i) . $3;
      $n = $';
    } else {
      last;
    }
  }

  # --- If there's a menu then process that ---

  if ($n =~ /\n\* *Menu:/s) {
    $out .= $` . $&;
    $n = $';
    for (;;) {
      if ($n =~ /(\n\* *)([^:]*: *(?:\([^\)]*\))?[^.,;:]*)([.,;:])/) {
	$out .= $` . $1 . subst($2, $file, $i) . $3;
	$n = $';
      } else {
	last;
      }
    }
  }
  $out .= $n;

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

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

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

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

  # --- Spot manpage references ---

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

  # --- Fix up the HTML ---

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

  header("Info: ($file)$node");
  print("<pre>\n$out</pre>\n");
  footer();
}

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

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

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