chiark - git - mdw - sw-tools/blob - perl/SWInfo.pm

   1 # -*-perl-*-
   2 #
   3 # $Id: SWInfo.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
   4 #
   5 # Read and output GNU Info files
   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: SWInfo.pm,v $
  31 # Revision 1.1  1999/07/30 18:46:37  mdw
  32 # New CGI script for browsing installed software and documentation.
  33 #
  34
  35 #----- Package preamble -----------------------------------------------------
  36
  37 package SWInfo;
  38
  39 use IO;
  40
  41 use SWConfig;
  42 use SWCGI qw(:DEFAULT :layout);
  43 use SWMan;
  44 use Info;
  45
  46 #----- Useful functions -----------------------------------------------------
  47
  48 # --- @subst(IREF, FILE, INFO)@ ---
  49 #
  50 # Given an Info reference and the name of the current Info file, returns an
  51 # HTML anchor which represents the link.
  52
  53 sub subst($$$) {
  54   my ($iref, $file, $i) = @_;
  55   my $node;
  56   my $dir;
  57   my $tail = "";
  58
  59   # --- Dig out the node and file being referred to ---
  60
  61   if ($iref =~ /:$/) {
  62     $tail = ":";
  63     $iref = $`;
  64   }
  65   my $oref = $iref;
  66   $iref =~ s/\s+/ /g;
  67   if ($iref =~ /^.+: *(.+)$/) { $iref = $1; }
  68   if ($iref =~ /(?:\(([^\)]*)\))?(.*)$/) {
  69     $file = $1 || $file;
  70     $node = $2 || "Top";
  71   } else {
  72     $node = $iref;
  73   }
  74
  75   # --- Transform it into something that won't get mangled ---
  76
  77   $node =~ s/[+&=%]|[^ -~]/sprintf("%%%02x", ord($&))/eg;
  78   $node =~ tr/ /+/;
  79
  80   ($dir = $i->{dir}) =~ s:$C{prefix}/info/?::;
  81   $dir = "&dir=$dir" if $dir;
  82
  83   return "<a href=\"$ref?act=info&file=$file&node=$node$dir\">$oref</a>$tail";
  84 }
  85
  86 #----- Actions --------------------------------------------------------------
  87
  88 sub info {
  89   my $file = $Q{file} || "dir";
  90   my $node = $Q{node} || "Top";
  91   my $dir = $Q{dir} || "";
  92   my $out;
  93
  94   # --- Read the node in ---
  95
  96   Info::setpath("$C{prefix}/info");
  97
  98   "$dir/$file" =~ m:\./: and
  99     barf("bad filename `$dir/$file'");
 100   my $i = (($dir && Info->new("$dir/$file")) ||
 101            Info->new($file))
 102     or barf("couldn't find info file `$file'");
 103   my $n = $i->node($node) or
 104     barf("info file `$file' doesn't contain node `$node'");
 105
 106   # --- Now translate the node into HTML, first line first ---
 107
 108   $n =~ s/\&/&amp;/;
 109   $n =~ s/\</&lt;/;
 110   $n =~ s/\>/&gt;/;
 111   $n =~ s/\A( [^\n]* Next:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
 112   $n =~ s/\A( [^\n]* Prev:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
 113   $n =~ s/\A( [^\n]* Up:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
 114
 115   # --- Grind through picking up any notes ---
 116
 117   $out = "";
 118
 119   for (;;) {
 120     if ($n =~ /(\*Note\s*)([^:]*: *(?:\([^\)]*\))?[^.,;:]*)([.,;:])/i) {
 121       $out .= $` . $1 . subst($2, $file, $i) . $3;
 122       $n = $';
 123     } else {
 124       last;
 125     }
 126   }
 127
 128   # --- If there's a menu then process that ---
 129
 130   if ($n =~ /\n\* *Menu:/s) {
 131     $out .= $` . $&;
 132     $n = $';
 133     for (;;) {
 134       if ($n =~ /(\n\* *)([^:]*: *(?:\([^\)]*\))?[^.,;:]*)([.,;:])/) {
 135         $out .= $` . $1 . subst($2, $file, $i) . $3;
 136         $n = $';
 137       } else {
 138         last;
 139       }
 140     }
 141   }
 142   $out .= $n;
 143
 144   $out =~ s!(http|ftp)://[^]&)\s]*[^]&).,\s\'\"]!<a href="$&">$&</a>!g;
 145   $out =~ s![^\s()&;{}.,\`\"][^\s()&;{}\`\"]*\@[^\s()&;{}\'\"]*[^\s()&;{}.,\'\"]!<a href="mailto:$&">$&</a>!g;
 146   $out =~ s!([-_.\w]+)\((\d+\w*)\)!SWMan::subst("$1($2)", $1, $2)!eg;
 147
 148   header("Info: ($file)$node");
 149   print("<pre>\n$out</pre>\n");
 150   footer();
 151 }
 152
 153 #----- Actions provided -----------------------------------------------------
 154
 155 $main::ACT{"info"} = \&info;
 156
 157 #----- That's all, folks ----------------------------------------------------