package PackageTool;

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

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

# 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
# value 1 means used, value 2 means used and found
my %USED_FILES;

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

my %USED_HARD_LINK;

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

sub find_hard_links($$)
{
  my $path = shift;
  my $ino = shift;
  my %link_hash;

  # 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;
    }
    $link_hash{$dir . $file} = 1 if ($other_ino == $ino);
  }
  closedir DIR;
  return \%link_hash;
}   

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

  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 _);

  # without leading slash
  my $key = substr($path, 1);
  $USED_FILES{$key} = 1;

  if ($path ne $org_path) # symbolic link
  {
    printf("%s -> %s\n", $org_path, $path);
    $USED_SYMLINK{substr($org_path, 1)} = 1;
  }
  if ($nlink > 1)
  {
    my $link_hash = find_hard_links($path, $ino);
    my $line = join(' ', keys(%$link_hash));
    printf "%s(%d) => %s\n", $path, $nlink, $line;
    $USED_HARD_LINK{$key} = $link_hash;
  }
  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 'CC'
#
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 '/');

        # 2002-12-18 src/scanner/file.sh requires a dereferenced path
	$path = add_path($path);
	next if (!defined($path));

	# 2002-12-18 this is how it was before
	# Probably had a good reason, but I forgot it
	# 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_man
#
# 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. 
#
sub determine_man(@)
{
  my $man_sys = ($ENTITY{'UNAME'} eq 'SunOS') ? 'SunOS' : 'GNU';
  my $man_func = \&{'pkg_man::man_add_' . $man_sys}; 
  &$man_func(@_);
}

#
# determine
#
# Name and version of the packages owning the all files in
# %USED_FILES are determined and stored in %PACKAGES.
#
sub determine()
{
  my $pkg_sys = $ENTITY{'OS_PKG_SYS'};

  my $pkg_func = \&{'pkg_ver::pkg_init_' . $pkg_sys};
  my $msg = &$pkg_func();
  die $msg if (defined($msg));

  $pkg_func = \&{'pkg_ver::pkg_ver_' . $pkg_sys};
  $msg = &$pkg_func(\%USED_FILES, \%PACKAGES);
  die $msg if (defined($msg));

  my $not_found = 0;
  while (my ($key, $value) = each(%USED_FILES))
  {
    next if ($value >= 2);
    printf "File not found: /%s\n", $key;

    my $entity = uc($key);
    $entity =~ s/\W/_/g;
    $entity =~ s/[0-9_]+$//; # usr_bin_perl_5_005 => usr_bin_perl
    $ENTITY{'NOPKG_' . $entity} = 1;

    $not_found++;
    my $hard_link = $USED_HARD_LINK{$key};
    next if (!defined($hard_link));

    if ($pkg_sys ne 'FreeBSD')
    {
      print "Searching packages owning hard links ...\n";
      $msg = &$pkg_func($hard_link, \%PACKAGES);
      die $msg if (defined($msg));
      my $found = 0;
      while (my ($key, $value) = each(%$hard_link))
      {
	next if ($value == 1);
	printf "Hard link found: /%s\n", $key;
	$found = 1;
      }
      $not_found-- if ($found);
    }
  }
  my @f = keys(%USED_FILES);
  my @s = keys(%USED_SYMLINK);
  my @p = keys(%PACKAGES);
  printf "files=%d, symlinks=%d, found packages=%d, files not found=%d\n",
    $#f, $#s, $#p, $not_found;
}

#
# 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";
}

1;
