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

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