Slight improvements to URL and email address parsing.

[sw-tools] / perl / Info.pm

# -*-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;