New CGI script for browsing installed software and documentation.

[sw-tools] / perl / SWInfo.pm

diff --git a/perl/SWInfo.pm b/perl/SWInfo.pm
new file mode 100644 (file)
index 0000000..04898df
--- /dev/null
+++ b/perl/SWInfo.pm
@@ -0,0 +1,157 @@
+# -*-perl-*-
+#
+# $Id: SWInfo.pm,v 1.1 1999/07/30 18:46:37 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.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;
+
+  $out =~ s!(http|ftp)://[^]&)\s]*[^]&).,\s\'\"]!<a href="$&">$&</a>!g;
+  $out =~ s![^\s()&;{}.,\`\"][^\s()&;{}\`\"]*\@[^\s()&;{}\'\"]*[^\s()&;{}.,\'\"]!<a href="mailto:$&">$&</a>!g;
+  $out =~ s!([-_.\w]+)\((\d+\w*)\)!SWMan::subst("$1($2)", $1, $2)!eg;
+
+  header("Info: ($file)$node");
+  print("<pre>\n$out</pre>\n");
+  footer();
+}
+
+#----- Actions provided -----------------------------------------------------
+
+$main::ACT{"info"} = \&info;
+
+#----- That's all, folks ----------------------------------------------------