#!/usr/bin/perl -w

=head1 NAME

install-int-fiction - a frontend to the interactive fiction archive

=cut

# Copyright (C) 2001,2002  Robert Bihlmeyer
#
# This program 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.
#
# This program 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 this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

=head1 SYNOPSIS

B<install-int-fiction> [I<OPTIONS>] B<update>

B<install-int-fiction> [I<OPTIONS>] B<install> I<GAME>...

B<install-int-fiction> [I<OPTIONS>] B<remove> I<GAME>...

B<install-int-fiction> [I<OPTIONS>] B<list>

B<install-int-fiction> [I<OPTIONS>] B<search> I<PATTERN>...

B<install-int-fiction> [I<OPTIONS>] B<show> I<GAME>...

=head1 DESCRIPTION

B<install-int-fiction> manages a collection of zcode programs. Most of
these programs are interactive fiction games. This tool is written to
work with the B<if-archive> that is mirrored on various sites around
the globe and accessible by http or ftp.

=cut

use Fcntl ':flock';
use Getopt::Long;
use Pod::Usage;
use POSIX 'ENOENT';
use Text::Wrap;

use strict;

(my $Version = q$Revision: 1.3$) =~ s/Revision: //;

# where to get the zcode games
my $URL      = 'http://www.ifarchive.org/if-archive/games/zcode';

# directory which will hold state information
my $StateDir = '/var/lib/if-installer';

# directory where zcode games are kept
my $ZDir     = '/usr/share/games/zcode';

# what provides LWP?
my $ProvidesLWP = "the 'libwww-perl' package";

# names of state files
my $Index    = "$StateDir/index";
my $Registry = "$StateDir/registry";
my $Lock     = "$StateDir/lock";

my $Columns  = $ENV{COLUMNS} || 80;
$Text::Wrap::columns = $Columns;

my ($ua, $download, $print_uri, $regexp, $names_only);

sub lwp_init()
{
  return if $ua;
  eval 'use LWP::UserAgent';
  if ($@) {
    $@ =~ m"Can't locate LWP/UserAgent\.pm" or die $@;
    warn wrap('', '', "Warning: Perl WWW library (LWP) not found -- try installing $ProvidesLWP. I'll force --no-download mode for now ...\n");
    $download = 0;
    return;
  }
  $ua = new LWP::UserAgent;
  $ua->env_proxy();
}

=pod

The C<update> command refreshes our local copy of the B<if-archive>'s
index of zcode games. This will be called automatically by the other
commands if there is no local copy available yet. You may want to
re-run it regularly.

=cut

sub update()
{
  if ($print_uri) {
    print "$URL/Index\n";
    return;
  }
  lwp_init() if $download;
  $download or die wrap('','',"I can't do much in no-download mode. You could fetch <URL:$URL/Index> through other means and put it at $Index\n");
  my $res = $ua->mirror("$URL/Index", $Index);
  $res->is_success or $res->code == 304
    or die("error fetching <$URL/Index>: ",$res->status_line,"\n");
}

sub lock()
{
  open(Lock, ">$Lock") or die "couldn't create $Lock: $!";
  flock(Lock, LOCK_EX) or die "couldn't lock $Lock: $!";
  $SIG{__DIE__} = sub { unlink $Lock };
}

my %game;

sub snarf($ )
{
  lock if $_[0] && !$print_uri;
  -e $Index or update();
  open(Index, $Index) or die "could not read '$Index': $!\n";
  my $game;
  while (<Index>) {
    chomp;
    /^$/		and undef($game),			 next;
    $game && /^\s+(.*)/	and $game{$game}{desc} .= " $1",	 next;
    /(.+?\.z\d)\s+(.*)/	and $game = $1, $game{$game}{desc} = $2, next;
  }
  close(Index);
  if (open(Registry, $Registry)) {
    while (<Registry>) {
      chomp;
      $game{$_}{installed} = 1;
    }
    close(Registry);
  } elsif ($! != ENOENT) {
     warn("could not read '$Registry': $!\n");
   }
}

sub dump_reg()
{
  open(Registry, ">$Registry+") or die "could not write to '$Registry+': $!";
  foreach (sort keys %game) {
    print Registry "$_\n" if $game{$_}{installed};
  }
  close(Registry);
  rename("$Registry+", $Registry)
    or die "could not rename '$Registry+' to '$Registry': $!";
}

sub register($ )
{
  my ($g) = @_;
  return if $game{$g}{installed};
  -e "$ZDir/$g"
    or warn("$ZDir/$g does not exist",
	    $download ? '' : ', and I am in no-download mode',"\n"), return;
  $game{$g}{installed} = 1;
  dump_reg();
}

sub unregister($ )
{
  my ($g) = @_;
  return unless $game{$g}{installed};
  $game{$g}{installed} = 0;
  dump_reg();
}

sub match_games(@)
{
  my @p;
  for my $g (@_) {
    my $p = quotemeta($g);
    $p =~ /\\.z\d$/ or $p .= '\.z\d';
    my @m = grep { /^$p$/i } keys(%game);
    @m or warn "Warning: no game named '$g' found\n";
    push(@p, @m);
  }
  return @p;
}

### shorten($str, $len)
# take the first sentence from $str, shortening it to under $len characters
# using "..." if necessary.
sub shorten($$)
{
  my ($str, $len) = @_;
  return $str if length $str <= $len;
  my $d = index($str, '.');
  return substr($str, 0, $d + 1) if $d >= 0 && $d < $len;
  return substr($str, 0, $len - 3).'...';
}

### list_games(&pred)
# print a line with $game's name and shortened description
sub list_games(&)
{
  my ($pred) = @_;
  foreach (sort keys %game) {
    &$pred($_) and
      print "$_ - ",shorten($game{$_}{desc}, $Columns - length($_) - 3),"\n";
  }
}

=pod

The C<install> command tries to download all known games matching its
arguments from the B<if-archive>. Every game that is successfully
downloaded will be installed and registered.

=cut

sub install(@)
{
  snarf(1);
  my @p = match_games(@_);
  return unless @p;
  lwp_init() if $download;
  foreach (@p) {
    if ($print_uri) {
      print "$URL/$_\n";
    } else {
      if ($download) {
	my $res = $ua->mirror("$URL/$_", "$ZDir/$_");
	if ($res->code == 304) {
	  print "$_ is already current\n";
	} elsif (!$res->is_success) {
	  warn("could not fetch '$URL/$_': ",$res->status_line,"\n");
	  next;
	}
      }
      register($_);
    }
  }
}

=pod

The C<remove> command, unsurprisingly, removes all installed games
given on the commandline.

=cut

sub remove(@)
{
  snarf(1);
  my @p = match_games(@_);
  return unless @p;
  foreach (@p) {
    if (-e "$ZDir/$_") {
      unlink("$ZDir/$_") or warn("could not remove '$ZDir/$_': $!\n"), next;
    } elsif (!$game{$_}{installed}) {
      warn("ignoring removal of uninstalled game $_\n");
      next;
    }
    unregister($_);
  }
}

=pod

The C<search> command can be used to search for substrings in the
names and descriptions of all known games. If the --regexp switch is
given, the arguments are interpreted as Perl regular expressions (see
perlre(1)) instead.

Descriptions are not searched if the --names-only switch is used.

All searching is case-insensitive.

=cut

sub search(@)
{
  snarf(0);
  my $p = '(?:'.(join '|', $regexp ? @_ : map { quotemeta $_ } @_).')';
  $names_only ? list_games { $_[0] =~ /$p/io }
	      : list_games { $_[0] =~ /$p/io || $game{$_[0]}{desc} =~ /$p/io };
}

=pod

The C<show> command displays the long descriptions of all known games given
on the commandline.

=cut

sub show(@)
{
  snarf(0);
  my @p = match_games(@_);
  return unless @p;
  my $indent = 0;
  foreach (@p) {
    $indent = length $_ if $indent < length $_;
  }
  my $tab = ' ' x ++$indent;
  while (1) {
    my $p = shift @p;
    print wrap($p.' ' x ($indent - length $p), $tab, $game{$p}{desc}),"\n";
    last unless @p;
    print "\n";
  }
}

=pod

The C<list> command lists all installed games with their short descriptions.

=cut

sub list()
{
  snarf(0);
  list_games { $game{$_[0]}{installed} };
}

=head1 OPTIONS

=over 4

=item B<--no-download>

If C<install>ing do not download the game from the B<if-archive>, just
use the file that is already there. (If the game does not exist
locally, an error is raised.)

=item B<--print-uris>

Do not download or register games (C<install>) or the index
(C<update>), just print out the URIs from where they would be
downloaded.

=item B<--regexp>

Declare the arguments to the C<search> command as regular expressions.

=item B<--names-only>

C<search> only the names of games, not their descriptions.

=item B<--help>

Prints a usage message and exits.

=item B<--version>

Prints the version and exits.

=cut

$download = 1;
GetOptions('no-download' => sub { $download = 0 },
	   'print-uris'	 => \$print_uri,
	   'regexp'	 => \$regexp,
	   'names-only'	 => \$names_only,
	   'help'	 => sub { pod2usage(1) },
	   'version'	 => sub { print "install-int-fiction $Version\n";
				  exit 0 }) or pod2usage(2);

for (shift @ARGV) {
  defined $_ or pod2usage("No command given");
  /^update$/  and update(),		    last;
  /^search$/  and search(@ARGV),	    last;
  /^show$/    and show(@ARGV),		    last;
  /^install$/ and install(@ARGV),	    last;
  /^list$/    and list,			    last;
  /^remove$/  and remove(@ARGV),	    last;
  pod2usage("Unknown command '$_'");
}
unlink $Lock;
exit 0;

=head1 EXAMPLES

=item B<install-int-fiction install curses dejavu>

will install C<Curses> and C<Deja Vu>.

=item B<install-int-fiction remove dejavu>

will remove C<Deja Vu>.

=item B<install-int-fiction search --names-only eat>

will search for available games including "eat" in their name.

=item B<install-int-fiction --regexp search '\bk?night'>

will search for availabale games that include words begining with "night" or
"knight" (but not, for example, "benighted") in their description or name.

=head1 FILES

=item F</var/lib/if-installer/index>

The local copy of the B<if-archive>'s index of zcode programs. The
C<update> command will keep it up-to-date, but you may place a new version
there yourself, for example if you are not connected to the Internet.

=item F</var/lib/if-installer/registry>

The list of all registered games. You should not modify this file yourself.

=head1 SEE ALSO

frotz(1), jzip(1), xzip(1)

=head1 AUTHOR

Robert Bihlmeyer <robbe@orcus.priv.at>

=head1 NOTES

The interface similarity to apt-get(1) is somewhat intentional. I also
copied the wart that you have to use two verbs on the commandline to do the
common thing. Maybe I should default to C<install> when no command was given?

=cut
