package PackageTool;

require Exporter;
  
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(
  add_path
  add_which
  determine
  write_xml_versions
);

use strict;
use Entity qw( %ENTITY check_eq );

# global variables
# 
# like %ENTITY, holds results of add_which
use vars qw( %PATH );

# key is page name, value is path
use vars qw( %MANPAGES );

# keys are full path names, but without leading slash
my %USED_FILES;

# key is package name, value is version
my %PACKAGES;

#
# add_path
#
sub add_path($;$)
{
  my $path = shift;
  my $plain_file = shift;

  while(1)
  {
    my $p = readlink($path);
    last if (!defined($p));

    # is target of link specified absolute (with leading slash)?
    if (substr($p, 0, 1) eq '/')
    {
      $path = $p;
      next;
    }

    # cut off file name from path (leave directory),
    # then apppend file name and resolve all relative steps ('/../')
    $path =~ s#[^/]+$##;
    $path .= $p;
    while($path =~ s#/[^/]+/../#/#) {}
  }

  my (
    $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime,
    $mtime, $ctime, $blksize, $blocks
  ) = stat($path);
  return undef if (!defined($dev));
  return undef if (!defined($plain_file) && ! -x _);

  if ($nlink == 1)
  {
    # substr cuts off leading slash
    $USED_FILES{substr($path, 1)} = 1;
    return $path;
  }
 
  # If the file is hard-linked we search the directory for other
  # files having the same inode.
  my $dir = $path;
  $dir =~ s#[^/]+$##;
  opendir(DIR, $dir) || die "Can't opendir $dir: $!";
 
  # cut off leading slash
  $dir =~ s#^/##;
  for my $file(readdir(DIR))
  {
    next if ($file =~ m/^\./);
    my ( $other_dev, $other_ino ) = stat('/' . $dir . $file);
    if (!defined($other_ino))
    {
      printf "WARNING: Can't stat /%s%s: $!\n", $dir, $file;
      next;
    }
    $USED_FILES{$dir . $file} = 1 if ($other_ino == $ino);
  }
  closedir DIR;
   
  return $path;
}

#
# add_which
#
# Can be called with exactly two arguments:
#   add_which(0, 'nasm');
#   This will look for 'nasm', and store result in 'NASM'
#
# Can be called with more than two arguments:
#   add_which(1, 'CC', 'gcc', 'cc', 'c89');
#   This will store results in 'CSH'
#
sub add_which($$@)
{
  my $fatal = shift;
  my $symbol = ($#_ == 0) ? uc($_[0]) : shift();

  for my $name(@_)
  {
    # On SunOS 5.6 the POSIX confirming variations are in a special directory
    my $path = '/usr/xpg4/bin/' . $name;
    if (!defined(add_path($path)))
    {
      # On SunOS 5.6 packages install stuff info /usr/bin and create
      # a hard link into /bin. pkgchk does not find it in /bin, though.
      $path = '/usr/bin/' . $name;
      if (!defined(add_path($path)))
      {
	$path = `which $name`;
	chomp $path;

	# if first character is not a slash, then it is an error message,
	# not an absolute path
	next if (substr($path, 0, 1) ne '/');
	next if (!defined(add_path($path)));
      }
    }
    return $PATH{$symbol} = $path;
  }
  return undef if (!$fatal);
  my $msg = 'Unsuccesfully searched PATH for ';
  if ($#_ < 2)
    { $msg .= join(' or ', @_); }
  else
    { $msg .= ' one of ' . join(', ', @_); }
  die $msg;
}

#
# determine
#
# Arguments are a list of keywords for man-pages (actually all sections
# are searched for each term). For each man-page the the files holding
# its source (nroff or whatever) is searched and added to %USED_FILES. 
#
# Then name and version of the packages owning the all files in
# %USED_FILES are determined and stored in %PACKAGES.
#
#
sub determine(@)
{
  my $man_sys = ($ENTITY{'UNAME'} eq 'SunOS') ? 'SunOS' : 'GNU';
  my $man_func = \&{'man_add_' . $man_sys}; 
  &$man_func(@_);

  my $pkg_sys = $ENTITY{'OS_PKG_SYS'};
  my $pkg_func = \&{'pkg_ver_' . $pkg_sys};
  &$pkg_func;
}

#
# write_xml_versions
#
# write contents of %PACKAGES, i.e. the result of 'determine' as XML
# (complete <simplelist>)
#
sub write_xml_versions($)
{
  my $FILE = shift;

  my $max_len = 0;
  my $str;
  for my $key(sort(keys(%PACKAGES)))
  {
    my $version = $PACKAGES{$key};
    my $member = $key;
    $member .= '-' . $version if ($version ne '');
    my $len = length($member);
    $max_len = $len if ($len > $max_len);
    $str .= "<member><literal>" . $member . "</literal></member\n>";
  }

  return if ($max_len == 0);

  printf $FILE "<!-- widest column is %d characters -->\n", $max_len;
  my $columns = int(76 / $max_len);
  $columns = 1 if ($columns < 1);

  printf $FILE "<para><simplelist columns=\"%d\" type=\"horiz\"\n>", $columns;
  print $FILE $str . "</simplelist></para>\n";
}

#
# pkg_store_rpm
#
sub pkg_store_rpm()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  for $_(@$line) { m/([^ ]+) ([^ ]+)/; $PACKAGES{$1} = $2; }
  return undef;
}

#
# pkg_ver_rpm
#
# trivial single-pass 
#
sub pkg_ver_rpm()
{
  add_which 1, 'rpm';

  my $cmd = 'rpm -q --qf \'%{name} %{version}-%{release}\n\' -f /'
  . join(' /', keys(%USED_FILES)) . ' |';
  my $msg = Entity::parse_file(__PACKAGE__ . '::pkg_store_rpm', $cmd);
  die $msg if (defined($msg));
}

#
# pkg_store_deb_name
#
# parse output of 'dpkg -S'
#
sub pkg_store_deb_name()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  for $_(@$line)
  {
    m/(.+):/ || return "Output of dpkg -S is invalid: $_";
    $PACKAGES{$1} = 0;
  }
  return undef;
}

#
# pkg_store_deb_ver
#
# read all lines of /var/lib/dpkg/status
#
sub pkg_store_deb_ver()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  my $package;
  for $_(@$line)
  {
    if (m/^Package: (.+)/) { $package = $1; }
    elsif (m/^Version: (.+)/ && defined($PACKAGES{$package})) 
    {
      $PACKAGES{$package} = $1;
    }
  }
  return undef;
}

#
# pkg_ver_deb
#
# less trivial two-pass
#
sub pkg_ver_deb()
{
  add_which 1, 'dpkg';
  add_which 1, 'debsums';
  add_which 1, 'readlink';

  my $cmd = 'dpkg -S /' . join(' /', keys(%USED_FILES)) . ' |';
  my $msg = Entity::parse_file(
    __PACKAGE__ . '::pkg_store_deb_name', $cmd
  );
  die $msg if (defined($msg));

  $msg = Entity::parse_file(
    __PACKAGE__ . '::pkg_store_deb_ver', '/var/lib/dpkg/status'
  );
  die $msg if (defined($msg));
}

#
# pkg_store_slackware_name
#
# read each file in /var/log/packages/
# decoding of package names according to /sbin/upgradepkg of Slackware 8.1
#
sub pkg_store_slackware_name()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  my @segments = split /-/, $base;
  my $version = 0;
  if ($#segments >= 3)
  {
    $version = $segments[$#segments - 2];
    $base = join '-', @segments[0 .. ($#segments - 3)];
  }

  # read up to 'FILE LIST:' delimiter
  my $i = 0;
  while($$line[$i++] ne 'FILE LIST:') {}

  # ok, now look whether one of the files is part of %USED_FILES
  while($i <= $#$line)
  {
    $PACKAGES{$base} = $version if (defined($USED_FILES{$$line[$i++]}));
  }
  return undef;
}

#
# pkg_ver_slackware
#
# has no index of packages at all - lot of work
# 
sub pkg_ver_slackware()
{
  my $dir = '/var/log/packages/';
  opendir(DIR, $dir) || die "Can't opendir $dir: $!";
  for my $pkg_file(readdir(DIR))
  {
    next if ($pkg_file =~ m/^\./);
    my $msg = Entity::parse_file(
      __PACKAGE__ . '::pkg_store_slackware_name',
      '<' . $dir . $pkg_file,
      $pkg_file
    );
    die $msg if (defined($msg));
  }
  closedir DIR;
}

#
# pkg_ver_SunOS_name
#
sub pkg_store_SunOS_name()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  for $_(@$line)
  {
    $PACKAGES{$1} = 0 if (m/^\t(.+)/);
  }
  return undef;
}

#
# pkg_ver_SunOS_ver
#
sub pkg_store_SunOS_ver()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  my $pkg;
  for $_(@$line)
  {
    if (m/^([\w\d]+)/) { $pkg = $1; }
    elsif (m/^\s+\([^\)]*\)\s(.+)/) { $PACKAGES{$pkg} = $1; }
  }
  return undef;
}

#
# pkg_ver_SunOS
#
# This is two-pass.
#
# "pkgchk -l -p '/usr/bin/ls /usr/bin/sed'" is nicer than directly reading
# /var/sadm/install/contents
#
# "pkginfo -x SUNWcsu" is nicer than directly reading /var/sadm/pkg/SUNWcsu
#
sub pkg_ver_SunOS()
{
  add_which 1, 'pkgchk';
  add_which 1, 'pkginfo';

  my $cmd = 'pkgchk -l -p \'/' . join(' /', keys(%USED_FILES)) . '\' |';
  my $msg = Entity::parse_file(__PACKAGE__ . '::pkg_store_SunOS_name', $cmd);
  die $msg if (defined($msg));

  $cmd = 'pkginfo -x ' . join(' ', keys(%PACKAGES)) . '\' |';
  $msg = Entity::parse_file(__PACKAGE__ . '::pkg_store_SunOS_ver', $cmd);
  die $msg if (defined($msg));
}

#
# pkg_store_FreeBSD
#
sub pkg_store_FreeBSD()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  for $_(@$line)
  {
    next if ($_ eq '?');
    $PACKAGES{$_} = '';
  }
  return undef;
}

#
# pkg_ver_FreeBSD
#
sub pkg_ver_FreeBSD()
{
  add_which 1, 'pkg_which';
  my $cmd = 'pkg_which /' . join(' /', keys(%USED_FILES)) . ' |';
  my $msg = Entity::parse_file(__PACKAGE__ . '::pkg_store_FreeBSD', $cmd);
  die $msg if (defined($msg));
}

#
# man_store_GNU
#
sub man_store_GNU()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  # path is stored without leading slash
  for $_(@$line)
  {
    next unless (m#/([\S]+/)([^\s\./]+)(.*)#);
    my $file = $1 . $2 . $3;
    $USED_FILES{$file} = 1;
    $MANPAGES{$2} = $file;

  }
  return undef;
}

#
# man_add_GNU
#
sub man_add_GNU(@)
{
  my $cmd = 'man -a -w ' . join(' ', @_) . ' |';
  my $msg = Entity::parse_file(__PACKAGE__ . '::man_store_GNU', $cmd);
  die $msg if (defined($msg));
}

#
# man_store_SunOS
#
sub man_store_SunOS()
{
  my $line = shift;
  my $base = shift;
  my $filename = shift;

  for $_(@$line)
  {
    next unless (m#^\s*unformatted = /([\S]+/)([^\s\./]+)(.*)#);
    my $file = $1 . $2 . $3;

    # path is stored without leading slash
    $USED_FILES{$file} = 1;
    $MANPAGES{$2} = $file;
  }  
  return undef;
}

#
# man_add_SunOS
#
sub man_add_SunOS(@)
{
  my $cmd = 'man -a -d ' . join(' ', @_) . ' |';
  my $msg = Entity::parse_file(__PACKAGE__ . '::man_store_SunOS', $cmd);
  die $msg if (defined($msg));
}

1;
