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

   1 # -*-perl-*-
   2 #
   3 # $Id: SWInfo.pm,v 1.4 1999/08/24 12:15:33 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.4  1999/08/24 12:15:33  mdw
  32 # Properly sanitize CGI arguments (like `gtk+').
  33 #
  34 # Revision 1.3  1999/08/19 12:11:10  mdw
  35 # More improvements to URL recognizer.
  36 #
  37 # Revision 1.2  1999/08/18 17:10:07  mdw
  38 # Slight improvements to URL and email address parsing.
  39 #
  40 # Revision 1.1  1999/07/30 18:46:37  mdw
  41 # New CGI script for browsing installed software and documentation.
  42 #
  43
  44 #----- Package preamble -----------------------------------------------------
  45
  46 package SWInfo;
  47
  48 use IO;
  49
  50 use SWConfig;
  51 use SWCGI qw(:DEFAULT :layout);
  52 use SWMan;
  53 use Info;
  54
  55 #----- Useful functions -----------------------------------------------------
  56
  57 # --- @subst(IREF, FILE, INFO)@ ---
  58 #
  59 # Given an Info reference and the name of the current Info file, returns an
  60 # HTML anchor which represents the link.
  61
  62 sub subst($$$) {
  63   my ($iref, $file, $i) = @_;
  64   my $node;
  65   my $dir;
  66   my $tail = "";
  67
  68   # --- Dig out the node and file being referred to ---
  69
  70   if ($iref =~ /:$/) {
  71     $tail = ":";
  72     $iref = $`;
  73   }
  74   my $oref = $iref;
  75   $iref =~ s/\s+/ /g;
  76   if ($iref =~ /^.+: *(.+)$/) { $iref = $1; }
  77   if ($iref =~ /(?:\(([^\)]*)\))?(.*)$/) {
  78     $file = $1 || $file;
  79     $node = $2 || "Top";
  80   } else {
  81     $node = $iref;
  82   }
  83
  84   # --- Transform it into something that won't get mangled ---
  85
  86   $node = SWCGI::sanitize($node);
  87
  88   ($dir = $i->{dir}) =~ s:$C{prefix}/info/?::;
  89   $dir = "&dir=" . SWCGI::sanitize($dir) if $dir;
  90
  91   return "<a href=\"$ref?act=info&file=$file&node=$node$dir\">$oref</a>$tail";
  92 }
  93
  94 #----- Actions --------------------------------------------------------------
  95
  96 sub info {
  97   my $file = $Q{file} || "dir";
  98   my $node = $Q{node} || "Top";
  99   my $dir = $Q{dir} || "";
 100   my $out;
 101
 102   # --- Read the node in ---
 103
 104   Info::setpath("$C{prefix}/info");
 105
 106   "$dir/$file" =~ m:\./: and
 107     barf("bad filename `$dir/$file'");
 108   my $i = (($dir && Info->new("$dir/$file")) ||
 109            Info->new($file))
 110     or barf("couldn't find info file `$file'");
 111   my $n = $i->node($node) or
 112     barf("info file `$file' doesn't contain node `$node'");
 113
 114   # --- Now translate the node into HTML, first line first ---
 115
 116   $n =~ s/\&/&amp;/;
 117   $n =~ s/\</&lt;</;
 118   $n =~ s/\>/>&gt;/;
 119   $n =~ s/\A( [^\n]* Next:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
 120   $n =~ s/\A( [^\n]* Prev:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
 121   $n =~ s/\A( [^\n]* Up:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
 122
 123   # --- Grind through picking up any notes ---
 124
 125   $out = "";
 126
 127   for (;;) {
 128     if ($n =~ /(\*Note\s*)([^:]*: *(?:\([^\)]*\))?[^.,;:]*)([.,;:])/i) {
 129       $out .= $` . $1 . subst($2, $file, $i) . $3;
 130       $n = $';
 131     } else {
 132       last;
 133     }
 134   }
 135
 136   # --- If there's a menu then process that ---
 137
 138   if ($n =~ /\n\* *Menu:/s) {
 139     $out .= $` . $&;
 140     $n = $';
 141     for (;;) {
 142       if ($n =~ /(\n\* *)([^:]*: *(?:\([^\)]*\))?[^.,;:]*)([.,;:])/) {
 143         $out .= $` . $1 . subst($2, $file, $i) . $3;
 144         $n = $';
 145       } else {
 146         last;
 147       }
 148     }
 149   }
 150   $out .= $n;
 151
 152   # --- Spot URLs (except `mailto') ---
 153
 154   $out =~ s! \b (http s? | ftp | file | news) :
 155              [^]<>)\s]* [^]<>).,\s\']
 156            !urlsubst($&, $&)!egx;
 157
 158   # --- Spot email addresses (including `mailto' URLs) ---
 159
 160   $out =~ s! (?:\bmailto:)?
 161              ([^\s()<>&;:{}.,\`\'\"] [^\s()<>&;:{}\`\'\"]*
 162               \@
 163               [^\s()<>&;:{}\'\"]* [^\s()<>&;:{}.,\'\"])
 164            !<a href="mailto:$1">$&</a>!gx;
 165
 166   # --- Spot manpage references ---
 167
 168   $out =~ s! ([-_.\w]+) \( (\d+\w*) \)
 169            !SWMan::subst("$1($2)", $1, $2)!egx;
 170
 171   # --- Fix up the HTML ---
 172
 173   $out =~ s/\&lt;\</&lt;/g;
 174   $out =~ s/\>\&gt;/&gt;/g;
 175
 176   header("Info: ($file)$node");
 177   print("<pre>\n$out</pre>\n");
 178   footer();
 179 }
 180
 181 #----- Actions provided -----------------------------------------------------
 182
 183 $main::ACT{"info"} = \&info;
 184
 185 #----- That's all, folks ----------------------------------------------------