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

   1 # -*-perl-*-
   2 #
   3 # $Id: Info.pm,v 1.1 1999/07/30 18:46:36 mdw Exp $
   4 #
   5 # Manipulation and reading of 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: Info.pm,v $
  31 # Revision 1.1  1999/07/30 18:46:36  mdw
  32 # New CGI script for browsing installed software and documentation.
  33 #
  34
  35 #----- Package preamble -----------------------------------------------------
  36
  37 package Info;
  38 use IO;
  39 use POSIX;
  40 use Exporter;
  41 @ISA = qw(Exporter);
  42 @EXPORT_OK = qw(setpath);
  43
  44 #----- Low-level twiddling --------------------------------------------------
  45
  46 @infopath = ("/usr/info");
  47
  48 # --- @setpath(PATH...)@ ---
  49 #
  50 # Sets the Info search path.
  51
  52 sub setpath(@) {
  53   @infopath = @_;
  54 }
  55
  56 # --- @getname(INFO)@ ---
  57 #
  58 # Given the name of an Info manual, find the actual file.
  59
  60
  61 sub getname($) {
  62   my ($file) = @_;
  63
  64   foreach my $p (@infopath) {
  65     my $f = "$p/$file";
  66
  67     foreach my $suff ("", "-info", ".info") {
  68       return $f . $suff if -r $f . $suff;
  69       return $f . $suff . ".gz" if -r $f . $suff . ".gz";
  70     }
  71   }
  72   return undef;
  73 }
  74
  75 # --- @snarf(FILE)@ ---
  76 #
  77 # Snarf a file into a string, given its name.  Handles compressed files.
  78
  79 sub snarf($) {
  80   my ($f) = @_;
  81   local $/ = undef;
  82   my $snarf;
  83
  84   if ($f =~ /\.gz$/) {
  85     my $p = IO::Pipe->new();
  86     my $kid = fork();
  87     defined($kid) or return undef;
  88     if ($kid == 0) {
  89       $p->writer();
  90       dup2($p->fileno(), 1);
  91       exec("gzip", "-dc", $f);
  92       exit(127);
  93     }
  94     $p->reader();
  95     $snarf = $p->getline();
  96     $p->close();
  97     waitpid($kid, 0);
  98   } else {
  99     my $fh = IO::File->new($f, O_RDONLY) or return undef;
 100     $snarf = $fh->getline();
 101     $fh->close();
 102   }
 103   return $snarf;
 104 }
 105
 106 #----- An Info-file object --------------------------------------------------
 107
 108 # --- @node(NAME)@ ---
 109 #
 110 # Picks an individual node out of an Info file.
 111
 112 sub node {
 113   my ($me, $node) = @_;
 114   my $offset = 0;
 115   my $file;
 116   my $chunk;
 117
 118   # --- If there's an index, it will help me find the node ---
 119
 120   if ($me->{index}) {
 121     $offset = $me->{index}{lc($node)};
 122
 123     # --- Maybe the offset is into a different file ---
 124
 125     if ($me->{indir}) {
 126       my $loff = 0;
 127       PAIR: foreach my $pair (@{$me->{indir}}) {
 128         if ($pair->[0] <= $offset) {
 129           ($loff, $file) = @$pair;
 130         } else {
 131           last PAIR;
 132         }
 133       }
 134       return undef unless $file;
 135       $offset -= $loff;
 136     }
 137   }
 138
 139   # --- Fetch the file ---
 140
 141   if ($file) {
 142     my $fn;
 143
 144     $fn = "$me->{dir}/$file", -r $fn or
 145       $fn = "$me->{dir}/$file.gz", -r $fn or
 146         return undef;
 147
 148     if ($me->{cache}{$fn}) {
 149       $file = $me->{cache}{$fn};
 150     } else {
 151       $file = $me->{cache}{$fn} = snarf($fn) or return undef;
 152     }
 153   } else {
 154     $file = $me->{base};
 155   }
 156
 157   # --- Dig through the file to find the right node ---
 158
 159   GASP: for (;;) {
 160     pos $file = $offset;
 161     if ($file =~ / \G .*\1f\n
 162                    ([^\1f\n]* Node:\ *
 163                     \Q$node\E
 164                     [.,\n\t] [^\1f]*)
 165                    (?:\1f|\Z) /igsx) {
 166       $chunk = $1;
 167       last GASP;
 168     }
 169     $offset = 0, next GASP if $offset;
 170     last GASP;
 171   }
 172
 173   return $chunk;
 174 }
 175
 176 # --- @load(NAME)@ ---
 177 #
 178 # Loads a file into an Info object.
 179
 180 sub load {
 181   my ($me, $file) = @_;
 182   my $f = getname($file) or return undef;
 183   my $c = snarf($f) or return undef;
 184
 185   # --- Read the index, and maybe snarf in the indirection file ---
 186
 187   if (my ($index) = ($c =~ /\1f\nTag Table:\n([^\1f]*)\1f\nEnd Tag Table\n/s)) {
 188     my %index = ();
 189     while ($index =~ /Node: *([^\n\7f]*)\7f(\d+)\n/sg) { $index{lc($1)} = $2; }
 190     $me->{index} = \%index;
 191     if ($index =~ /^\(Indirect\)/ and
 192         my ($indir) = ($c =~ /\1f\nIndirect:\n([^\1f]*)\1f\n/s)) {
 193       my @indir = ();
 194       while ($indir =~ /([^\n:]*): *(\d+)\n/sg) { push(@indir, [$2, $1]); }
 195       $me->{indir} = \@indir;
 196     }
 197   }
 198
 199   ($me->{dir} = $f) =~ s:/[^/]*$::;
 200   $me->{base} = $c;
 201   return $me;
 202 }
 203
 204 # --- @new([NAME])@ ---
 205 #
 206 # Makes a new Info file and returns it to the caller.
 207
 208 sub new {
 209   my ($class, $file) = @_;
 210   my $me = bless {}, $class;
 211   return $me->load($file) if $file;
 212   return $me;
 213 }
 214
 215 #----- That's all, folks ----------------------------------------------------
 216
 217 1;