--- /dev/null
+# -*-perl-*-
+#
+# $Id: Info.pm,v 1.1 1999/07/30 18:46:36 mdw Exp $
+#
+# Manipulation and reading of 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: Info.pm,v $
+# Revision 1.1 1999/07/30 18:46:36 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package preamble -----------------------------------------------------
+
+package Info;
+use IO;
+use POSIX;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(setpath);
+
+#----- Low-level twiddling --------------------------------------------------
+
+@infopath = ("/usr/info");
+
+# --- @setpath(PATH...)@ ---
+#
+# Sets the Info search path.
+
+sub setpath(@) {
+ @infopath = @_;
+}
+
+# --- @getname(INFO)@ ---
+#
+# Given the name of an Info manual, find the actual file.
+
+
+sub getname($) {
+ my ($file) = @_;
+
+ foreach my $p (@infopath) {
+ my $f = "$p/$file";
+
+ foreach my $suff ("", "-info", ".info") {
+ return $f . $suff if -r $f . $suff;
+ return $f . $suff . ".gz" if -r $f . $suff . ".gz";
+ }
+ }
+ return undef;
+}
+
+# --- @snarf(FILE)@ ---
+#
+# Snarf a file into a string, given its name. Handles compressed files.
+
+sub snarf($) {
+ my ($f) = @_;
+ local $/ = undef;
+ my $snarf;
+
+ if ($f =~ /\.gz$/) {
+ my $p = IO::Pipe->new();
+ my $kid = fork();
+ defined($kid) or return undef;
+ if ($kid == 0) {
+ $p->writer();
+ dup2($p->fileno(), 1);
+ exec("gzip", "-dc", $f);
+ exit(127);
+ }
+ $p->reader();
+ $snarf = $p->getline();
+ $p->close();
+ waitpid($kid, 0);
+ } else {
+ my $fh = IO::File->new($f, O_RDONLY) or return undef;
+ $snarf = $fh->getline();
+ $fh->close();
+ }
+ return $snarf;
+}
+
+#----- An Info-file object --------------------------------------------------
+
+# --- @node(NAME)@ ---
+#
+# Picks an individual node out of an Info file.
+
+sub node {
+ my ($me, $node) = @_;
+ my $offset = 0;
+ my $file;
+ my $chunk;
+
+ # --- If there's an index, it will help me find the node ---
+
+ if ($me->{index}) {
+ $offset = $me->{index}{lc($node)};
+
+ # --- Maybe the offset is into a different file ---
+
+ if ($me->{indir}) {
+ my $loff = 0;
+ PAIR: foreach my $pair (@{$me->{indir}}) {
+ if ($pair->[0] <= $offset) {
+ ($loff, $file) = @$pair;
+ } else {
+ last PAIR;
+ }
+ }
+ return undef unless $file;
+ $offset -= $loff;
+ }
+ }
+
+ # --- Fetch the file ---
+
+ if ($file) {
+ my $fn;
+
+ $fn = "$me->{dir}/$file", -r $fn or
+ $fn = "$me->{dir}/$file.gz", -r $fn or
+ return undef;
+
+ if ($me->{cache}{$fn}) {
+ $file = $me->{cache}{$fn};
+ } else {
+ $file = $me->{cache}{$fn} = snarf($fn) or return undef;
+ }
+ } else {
+ $file = $me->{base};
+ }
+
+ # --- Dig through the file to find the right node ---
+
+ GASP: for (;;) {
+ pos $file = $offset;
+ if ($file =~ / \G .*\1f\n
+ ([^\1f\n]* Node:\ *
+ \Q$node\E
+ [.,\n\t] [^\1f]*)
+ (?:\1f|\Z) /igsx) {
+ $chunk = $1;
+ last GASP;
+ }
+ $offset = 0, next GASP if $offset;
+ last GASP;
+ }
+
+ return $chunk;
+}
+
+# --- @load(NAME)@ ---
+#
+# Loads a file into an Info object.
+
+sub load {
+ my ($me, $file) = @_;
+ my $f = getname($file) or return undef;
+ my $c = snarf($f) or return undef;
+
+ # --- Read the index, and maybe snarf in the indirection file ---
+
+ if (my ($index) = ($c =~ /\1f\nTag Table:\n([^\1f]*)\1f\nEnd Tag Table\n/s)) {
+ my %index = ();
+ while ($index =~ /Node: *([^\n\7f]*)\7f(\d+)\n/sg) { $index{lc($1)} = $2; }
+ $me->{index} = \%index;
+ if ($index =~ /^\(Indirect\)/ and
+ my ($indir) = ($c =~ /\1f\nIndirect:\n([^\1f]*)\1f\n/s)) {
+ my @indir = ();
+ while ($indir =~ /([^\n:]*): *(\d+)\n/sg) { push(@indir, [$2, $1]); }
+ $me->{indir} = \@indir;
+ }
+ }
+
+ ($me->{dir} = $f) =~ s:/[^/]*$::;
+ $me->{base} = $c;
+ return $me;
+}
+
+# --- @new([NAME])@ ---
+#
+# Makes a new Info file and returns it to the caller.
+
+sub new {
+ my ($class, $file) = @_;
+ my $me = bless {}, $class;
+ return $me->load($file) if $file;
+ return $me;
+}
+
+#----- That's all, folks ----------------------------------------------------
+
+1;
~mdw / sw-tools / blobdiff