#!/s/what-0.1.31/depend/perl -w

# $Id: mkrpms.plm,v 1.3 2004/05/05 15:29:06 thomas Exp $

# Package to build an rpm database from a config file and a Red Hat
# comps.xml file

# $Log: mkrpms.plm,v $
# Revision 1.3  2004/05/05 15:29:06  thomas
# fix processing comps group keys.
#
# Revision 1.2  2004/03/05 15:15:14  thomas
# cconf->what
#
# Revision 1.1.1.1  2003/12/02 14:47:34  thomas
# Initial version before export to 0.1.1
#

package What::mkrpms;

use strict;
use XML::Simple;
use Data::Dumper;
use DirHandle;
use FileHandle;


###############################################################################
# configure -- take the name of a config file and build
# and number of rpm xml files.

sub configure {

  my $configfile = shift;

  # Get my master configuration
  my $config = readconfig ($configfile);

  # Create the initial framework for the output rpms
  setup ($config);

  # Get the Red Hat comps file
  my $comps = readcomps ($config->{compfile});

  # Expand the comps entries into rpm entries
  expandpckgs ($config, $comps);

  # Deal with implicit dependencies
  implicitdeps ($config, $comps);

  # Read the RPM directories and create the final config
  genlist ($config);

  # Write the output files
  writefiles ($config);
  return 0;

}


###############################################################################
# Add packages that are only listed in the <package> section
# of the comps file.

sub implicitdeps {
  my $config = shift;
  my $comps  = shift;

  my ($packagename, $rpmname, $rpm);

  foreach $packagename (keys %{$config->{work}}) {
    foreach $rpmname (keys %{$config->{work}->{$packagename}->{rpms}}) {
      $rpm = $config->{work}->{$packagename}->{rpms}->{$rpmname}->[0];
      (exists ($rpm->{noimplicitdeps}) &&
       defined ($rpm->{noimplicitdeps}) &&
       $rpm->{noimplicitdeps}) and next;
      chkimplicit ($config, $comps, $packagename, $rpmname);
    }
  }
}

##############################################################################

sub chkimplicit {
  my $config = shift;
  my $comps  = shift;
  my $package = shift;
  my $rpmname = shift;

  my $dep;

  if (!defined ($comps->{package}->{$rpmname})) {
    $::opts{debug}>3 and print STDERR "No implicit dependencies found for $rpmname!\n";
    return;
  }

  foreach $dep (@{$comps->{package}->{$rpmname}->{dependencylist}->{dependency}}) {
    if (!defined ($config->{work}->{$package}->{rpms}->{$dep})) {
      $::opts{debug}>2 and print STDERR "Adding implicit dependency $dep required by $rpmname ($package).\n";
      addrpm ($config, $package, $dep, undef, undef, undef, {});
      chkimplicit ($config, $comps, $package, $dep);
    }
  }
}

###############################################################################
# Write the final configs to a set of output files

sub writefiles{
  my ($config) = shift;

  my ($packagename, $key, $rpm, $fh, $date, $basename, %needdirs);
  $date = `date`;
  chomp $date;
  foreach $packagename (keys %{$config->{final}}) {
    %needdirs = ();
    $fh = new FileHandle "$config->{outdir}/$packagename.rpms.xml", "w";
    if (!defined ($fh)) {
      $::opts{debug}>0 and print STDERR "Failed to open output file $config->{outdir}/$packagename.rpms!\n";
      next;
    }
    print $fh <<__Eof__
<!-- THIS FILE IS AUTOMATICALLY GENERATED -->
<!-- CHANGES MADE BY HAND WILL BE LOST -->
<!-- Last built $date by $0 -->

<what>
__Eof__
  ;

    # RPMs
    foreach $key (sort keys %{$config->{final}->{$packagename}}) {
      $rpm = $config->{final}->{$packagename}->{$key};
      $needdirs{$rpm->{dirname}}=1;
      print $fh "  <node path=\"/Rpms/rpms/$rpm->{name}/$rpm->{version}-$rpm->{release}.$rpm->{arch}\" dir=\"$rpm->{dirname}\" ";

      $basename = "$rpm->{name}-$rpm->{version}-$rpm->{release}.$rpm->{arch}.rpm";
      ($rpm->{basename} ne $basename) and print $fh " file=\"$rpm->{basename}\" ";

      (defined $rpm->{ifarch}) and print $fh " ifarch=\"$rpm->{ifarch}\" ";

      print $fh " />\n";
    }

    print $fh "\n";

    # Directories
    my $dirname;
    foreach $dirname (sort keys %needdirs) {
      print $fh "  <node path=\"/Rpms/dirs/$dirname\" dir=\"$config->{dirnames}->{$dirname}->{dir}\" />\n";
    }

    print $fh "</what>\n";
    undef $fh;
  }
}

###############################################################################
# Generate the configuration file that the client will use to install its
# RPMs

sub genlist {
  my ($config) = shift;

  my $final = {};
  my ($packagename, $rpmname, $req, $rpm, $key);

  $::opts{debug}>4 and print Dumper ($config);

  foreach $packagename (keys %{$config->{work}}) {
    foreach $rpmname (keys %{$config->{work}->{$packagename}->{rpms}}) {
      foreach $req (@{$config->{work}->{$packagename}->{rpms}->{$rpmname}}) {
	$rpm = resolve (
			$config,
			name => $rpmname,
			%$req
		       );
	if (defined $rpm) {
	  $key = "$rpm->{name} $rpm->{version} $rpm->{release} $rpm->{arch}";
	  (defined $rpm->{ifarch}) and $key .= $rpm->{ifarch};
	  $config->{final}->{$packagename}->{$key} = $rpm;
	}
      }
    }
  }

  return;
}

###############################################################################
# Resolve abiguities in the passed RPM request
#
sub resolve {
  my $config = shift;
  my %args = ( @_ );

  my ($dir, $test, $res, $rpm);
  if ($args{name} eq 'kernel') {
    my $foo=1;
  }	
  foreach $dir (split (/,/, $args{dirs})) {
    read_dir ($config, $dir);
    foreach $test (@{$config->{dir}->{$dir}->{contents}->{$args{name}}}) {
      ($args{version} ne 'any' && $args{version} ne $test->{version}) and next;
      ($args{release} ne 'any' && $args{release} ne $test->{release}) and next;
      ($args{arch}    ne 'any' && $args{arch}    ne $test->{arch})    and next;
      defined ($rpm) or goto useme;
      $res = isnewer ($test->{version}, $rpm->{version});
      $res<0 and next;
      $res>0 and goto useme;
      isnewer ($test->{release}, $rpm->{release}) > 0 and goto useme;
      next;

    useme:
      $rpm = {
	      name => $args{name},
	      version => $test->{version},
	      release => $test->{release},
	      #path    => $test->{path},
	      dirname  => $test->{dirname},
	      basename => $test->{basename},
	      arch    => $test->{arch},
	     };
      defined ($args{ifarch}) and $rpm->{ifarch} = $args{ifarch};
    }
  }
  return $rpm;
}


###############################################################################
# Compare the versions passed as args
sub isnewer {
  my ($new, $old) = @_;

  my ($debug, $pnew, $pold);
  $debug=0;
  # Strip path components
  while (1) {
    $debug and print STDERR "Comparing $new with $old\n";
    # Get next element from version
    if ($new =~ /^(\d+)/) {
      # Make next compare numeric
      $pnew = $1;
      $new =~ s/^(\d+)[\-.]?//;
      if (!($old =~ /^(\d+)/)) {
        $debug && print STDERR "Numeric $pnew from new, nothing from old\n";
        return 1;
      }
      $pold = $1;
      $old =~ s/^(\d+)[\-.]?//;
      if ($pnew != $pold) {
        return ($pnew <=> $pold);
      }
      next;   # Get some more
    } elsif ($new =~ /(\w+)/) {
      # Make next compare alpha
      $pnew = $1;
      $new =~ s/^(\w+)[\-.]*//;
      if (!($old =~ /^(\w+)/)) {
        $debug && print STDERR "Alpha $pnew from new, nothing from old\n";
        return 1;
      }
      $pold = $1;
      $old =~ s/^(\w+)[\-.]*//;
      if ($pnew ne $pold) {
        return ($pnew cmp $pold);
      }
      next;   # Get some more
    } else {
      $debug && print STDERR "I guess they are equal?\n";
      return ($new cmp $old);
    }
  }
}

###############################################################################
# Read a directory into the config structure

sub read_dir {
  my $config = shift;
  my $groupname   = shift;

  defined ($config->{dir}->{$groupname}->{contents}) and return 1;

  my ($source, $dh, $de, $install);
  my ($name, $version, $release, $arch);
  my $group = $config->{dir}->{$groupname};
  $group->{contents} = {};
  my ($sourceidx, $dirname) = (0, undef);
  foreach $source (@{$group->{source}}) {
    if (!defined ($group->{install})) {
      if ($sourceidx) {
	$dirname = sprintf "%s-%d", $groupname, $sourceidx;
      } else {
	$dirname = $groupname;
      }
      $sourceidx++;
    } else {
      $dirname = $groupname;
    }
    $install = $source;
    $install =~ s:/$::;
    defined ($group->{install}) and $install = $group->{install};
    $config->{dirnames}->{$dirname} = {
				       dir => $install,
				      };
    $dh = new DirHandle $source;
    if (!defined $dh) {
      $::opts{debug}>1 and print STDERR "Can't open directory $source for group $groupname!\n";
      next;
    }
    while (defined ($de = $dh->read)) {
      ($de =~ /\.rpm$/) || next;
      ($name, $version, $release, $arch) = ($de =~ /^(.*)-([^-]+)-([^-]+)\.(i\d+|noarch|athlon|none).rpm$/);
      if (!defined $name) {
	$::opts{debug}>1 and print STDERR "Can't parse rpm $source/$de!\n";
	next;
      }

      # Add to the by-name, by-version, and by-release entries
      exists ($group->{contents}->{$name}) or
	$group->{contents}->{$name} = [];
      push @{$group->{contents}->{$name}}, {
					    #path    => "$install/$de",
					    dirname => $dirname,
					    basename => $de,
					    version => $version,
					    release => $release,
					    arch    => $arch,
					   };
    }
  }
}

###############################################################################
# Create the initial framework of rpms.  This involves re-ordering the
# config data, sorting first by final rpm package name.

sub setup {
  my $config = shift;

  my ($comp, $pckg, $reqcomp, $rpm, $tcomp, $attr);

  # It's first-in-wins in addrpm, so prefer direct RPMs in the master
  # config to groups.
  foreach $rpm (@{$config->{rpms}}) {
    foreach $pckg (split (/,/, $rpm->{pckgs})) {
      if (defined ($rpm->{action}) &&
	  ($rpm->{action} eq 'delete' || $rpm->{action} eq 'replace')) {
	defined ($config->{work}->{$pckg}->{rpms}->{$rpm->{name}}) and
	  delete $config->{work}->{$pckg}->{rpms}->{$rpm->{name}};
      }
      if (!defined ($rpm->{action}) || $rpm->{action} ne 'delete') {
	# Default is to add it
	addrpm ($config, $pckg, undef, undef, undef, undef, $rpm);
      }
    }
  }

  foreach $comp (@{$config->{comps}}) {
    foreach $pckg (split (/,/, $comp->{pckgs})) {
      if (defined ($config->{work}->{$pckg}->{comps}->{$comp->{group}})) {
	$::opts{debug}>2 and print STDERR "Group $comp->{group} for package $pckg specified multiple times!\n";
	next;
      }
      $tcomp = {};
      foreach $attr ('dirs', 'prior', 'use', 'nouse', 'nouseall', 'useall') {
	exists ($comp->{$attr}) and $tcomp->{$attr} = $comp->{$attr};
      }
      $config->{work}->{$pckg}->{comps}->{$comp->{group}} = $tcomp;
    }
  }

  $::opts{debug}>4 and print Dumper ($config);
  return 1;
}

###############################################################################
# Expand the comp groups in the rpm entries and handle
# requisites and metapkgs

sub expandpckgs {

  my ($config, $comps) = @_;

  my ($packagename, $pckg, $needcomps, $donecomps, $workingcomps, $compname);

  foreach $packagename (keys %{$config->{work}}) {
    $::opts{debug}>2 and print STDERR "\nExpanding package $packagename\n";
    $pckg = $config->{work}->{$packagename};

    # Make a list of comps to do
    foreach (keys %{$pckg->{comps}}) {
      $needcomps->{$_} = 1;
    }
    $donecomps = {};
    $workingcomps = {};

    # Careful -- the list may change in expandcomp
    while (scalar (keys %$needcomps)) {
      $compname = (keys %$needcomps)[0];
      expandcomp ($config, $comps, $needcomps, $donecomps, $workingcomps, $packagename, $compname, '');
    }
  }

  # print Dumper ($config);

}

###############################################################################
# Resolve (in this order): requisites, metapkgs, and the item requested.

sub expandcomp {
  my ($config, $comps, $needcomps, $donecomps, $workingcomps, $packagename, $compname, $indent) = @_;

  my ($req, $rpmname, $conf, %use, %nouse, $rpm);

  # Check for circular ref and housekeeping
  defined ($workingcomps->{$compname}) and die "Ieeee! Circular requisites for group $compname for package $packagename: " . join (', ', keys %$workingcomps);
  delete $needcomps->{$compname};
  $workingcomps->{$compname} = 1;

  # Requisites
  $::opts{debug}>2 and print STDERR "${indent}Checking requisites for group $compname\n";
  if (defined ($comps->{group}->{$compname}->{grouplist}->{groupreq})) {
    foreach $req (@{$comps->{group}->{$compname}->{grouplist}->{groupreq}}) {
      defined ($donecomps->{$req}) and next;
      if (!defined ($needcomps->{$req})) {
	$::opts{debug}>2 and print STDERR "${indent}Adding implicit dependency $req ((comp $compname, package $packagename)\n";
	$needcomps->{$req} = 1;
      }
      # Don't curse - recurse!
      $::opts{debug}>2 and print STDERR "${indent}Recursing requisite comp $req (comp $compname, package $packagename)\n";
      expandcomp ($config, $comps, $needcomps, $donecomps, $workingcomps, $packagename, $req, $indent . '  ');
    }
  }
  $::opts{debug}>2 and print STDERR "${indent}Requisites satisfied for group $compname\n";


  $::opts{debug}>2 and print STDERR "${indent}Checking meta-packages for group $compname\n";
  if (defined ($comps->{group}->{$compname}->{grouplist}->{metapkg})) {
    foreach $req (@{$comps->{group}->{$compname}->{grouplist}->{metapkg}}) {
      if ($req->{type} eq 'optional') {
	$::opts{debug}>2 and print STDERR "${indent}Skipping optional metapkg $req->{content} for (comp $compname, package $packagename)\n";
	next;
      }
      defined ($donecomps->{$req->{content}}) and next;
      if (!defined ($needcomps->{$req->{content}})) {
	$::opts{debug}>2 and print STDERR "${indent}Adding implicit metapkg $req->{content} for ((comp $compname, package $packagename)\n";
	$needcomps->{$req} = 1;
      }
      # Don't curse - recurse!
      $::opts{debug}>2 and print STDERR "${indent}Recursing requisite comp $req->{content} (comp $compname, package $packagename)\n";
      expandcomp ($config, $comps, $needcomps, $donecomps, $workingcomps, $packagename, $req->{content}, $indent . '  ');
    }
  }
  $::opts{debug}>2 and print STDERR "${indent}Meta-packages satisfied for group $compname\n";


  # Have something to satisfy, now do it
  $::opts{debug}>2 and print STDERR "${indent}Expanding group $compname\n";
  foreach $rpmname (keys %{$comps->{group}->{$compname}->{packagelist}->{packagereq}}) {
    $req = $comps->{group}->{$compname}->{packagelist}->{packagereq}->{$rpmname};
    $conf = $config->{work}->{$packagename}->{comps}->{$compname};
    %use = ();
    %nouse = ();
    if (defined $conf->{use}  ) { foreach (split (/,/, $conf->{use}  )) { $use{$_} = 1;  }};
    if (defined $conf->{nouse}) { foreach (split (/,/, $conf->{nouse})) { $nouse{$_} = 1;}};
    defined ($conf->{useall}) or $conf->{useall} = 0;
    defined ($conf->{nouseall}) or $conf->{nouseall} = 0;
    # Use this package if:
    #  It's required  --or--
    #  It's default and it's not in the config nouse list and nouseall isn't set --or--
    #  It's optional and in the use list or (useall is set and the rpm isn't in the nouse list)
    #    I.e. nouse="rpm" applies even if useall="1" is specified
    #    Also, use="rpm" applies even if nouseall"1" is specified
    if (
	($req->{type} eq 'mandatory' && !exists ($nouse{$rpmname})) ||
	(($req->{type} eq 'default') && !exists ($nouse{$rpmname}) && !$conf->{nouseall}) ||
	(($req->{type} eq 'optional') && (exists ($use{$rpmname}))) ||
	($conf->{useall} && !exists ($nouse{$rpmname}))
       ) {
      $::opts{debug}>2 and print STDERR "Adding $rpmname\n";
      addrpm ($config, $packagename, $rpmname, undef, undef, undef, $conf);
    }
  }

  # Done -- mark it so...
  delete $workingcomps->{$compname};
  $donecomps->{$compname} = 1;
}


###############################################################################
# Add the passed rpm to the passed rpm data structure
sub addrpm {
  my ($config, $package, $name, $version, $release, $arch, $rpm) = @_;

  my $check;

  defined ($version) or $version = $rpm->{version};
  defined ($version) or $version = 'any';
  defined ($release) or $release = $rpm->{release};
  defined ($release) or $release = 'any';
  defined ($arch)    or $arch    = $rpm->{arch};
  defined ($arch)    or $arch    = 'any';
  defined ($name)    or $name    = $rpm->{name};
  defined ($name)    or die "addrpm called and I can't determine the name of the rpm!\n";

  my ($dirs, $prior) = ($rpm->{dirs}, $rpm->{prior});
  my ($list, $new);
  defined ($dirs) or $dirs = $config->{defaults}->{dirs};
  defined ($prior) or $prior = $config->{defaults}->{prior};
  (defined ($config->{work}->{$package}->{rpms}->{$name})) or
    $config->{work}->{$package}->{rpms}->{$name} = [];
  $list = $config->{work}->{$package}->{rpms}->{$name};
  foreach $check (@$list) {
    # Keep the first one we found
    ($check->{version} eq $version &&
     $check->{release} eq $release &&
    !defined ($rpm->{ifarch})) and return 1;
  }

  $new = {
	  version => $version,
	  release => $release,
	  arch    => $arch,
	  dirs    => $dirs,
	  prior   => $prior,
	 };
  defined ($rpm->{ifarch}) and $new->{ifarch} = $rpm->{ifarch};
  defined ($rpm->{noimplicitdeps}) and
    $new->{noimplicitdeps} = $rpm->{noimplicitdeps};
  push @$list, $new;
  return 1;
}


###############################################################################
sub readcomps {
  my $compfile = shift;

  my ($gkey, $newname, $name, $newdesc, $desc);

  # 10/24/03 DT -- parsing broke when 'name' was listed in both keyattr and
  # forcearray -- not sure what will break with 'name' out of forcearray
  # have to try it and find out...
  my $comps = XMLin
    (
     $compfile,
     keyattr => {
		 packagereq => 'content',
		 group      => 'id',
		 package    => 'name',
		},
     forcearray => [
		    'description',
		    'packagereq',
		    'dependency',
		    'groupreq',
		    'rpm',
#		    'name',
		    'metapkg',
		   ],
    );

  # print Dumper ($comps);
  # Clean up -- remove non-english names
  foreach $gkey (keys %{$comps->{group}}) {
    $newname = [];
    if (ref $comps->{group}->{$gkey}->{name}) {
      foreach $name (@{$comps->{group}->{$gkey}->{name}}) {
	# print "ref \$name is " . ref($name) . "\n";
	(ref ($name) eq 'HASH') or push @$newname, $name;
      }
    } else {
      push @$newname, $comps->{group}->{$gkey}->{name};
    }
    $comps->{group}->{$gkey}->{name} = $newname;
    $newdesc = [];
    if (defined $comps->{group}->{$gkey}->{description}) {
      foreach $desc (@{$comps->{group}->{$gkey}->{description}}) {
	(ref ($desc) eq 'HASH') or push @$newdesc, $desc;
      }
      $comps->{group}->{$gkey}->{description} = $newdesc;
    }
  }

  # print Dumper $comps;

  return $comps;
}

###############################################################################
sub readconfig {
  my $configfile = shift;

  my $config =   XMLin (
			$configfile,
			keyattr => {
				    dir => 'name',
				   },
			forcearray => [
				       'rpms',
				       'comps',
				       'source',
				      ],
		       );

  # print Dumper $config;
  exists ($config->{content}) and delete $config->{content};
  return $config;
}

###############################################################################

=head1 NAME

What::mkrpms -- perl module to create F<.rpms> files

=head1 DESCRIPTION

This module contains the code to expand a high-level xml file
containing general rpm requirements for systems into specific F<.rpms>
files which can be imported into B<what>.  The master xml file contains
references to groups in the F<comps.xml> file that came with the Red
Hat distribution.  Individual RPMs can be added or removed to further
customize the generated lists.

=head1 GORY DETAILS

=over 4

=item *

The master configuration file is read by B<readconfig()>.  This
file gives the directories that contain the RPM files, the F<.rpms>
files to be generated, the location of the F<comps.xml> file, and the
names of groups and individual RPMs to add/remove from the list(s).

=item *

The B<setup()> function is called.  For each component group and
output package requested by a B<comps> entry in the config file, this
step creates a
B<$config-E<gt>{work}-E<gt>{$pckg}-E<gt>{comps}-E<gt>{$comp}> entry.
Then, for each rpm listed in the B<rpms> section of the input file, a
B<$config-E<gt>{work}-E<gt>{$pckg}-E<gt>{rpms}-E<gt>{$name}> entry is
created for the named RPM.

=item *

The Red Hat distribution F<comps.xml> file is read by B<readcomps()>.

=item *

The B<expandpckgs()> function is called.  For each package, each
component listed in
B<$config-E<gt>{work}-E<gt>{$pckg}-E<gt>{comps}-E<gt>{$comp}>, the
component is expanded, and its equivalent RPM set is inserted into the
corresponding
B<$config-E<gt>{work}-E<gt>{$pckg}-E<gt>{rpms}-E<gt>{$name}> area.
Specifically, prerequisites are satisfied, meta-packages are expanded,
and the component itself is expanded.  B<use>, B<nouse>, B<useall>,
and B<nouseall> directives in the original config file for the group
controll the inclusion of optional components.  This is a recursive
step.

=item *

The B<implicitdeps()> function is called next.  For each RPM now
listed in
B<$config-E<gt>{work}-E<gt>{$pckg}-E<gt>{rpms}-E<gt>{$name}>, a check
is made via the loaded <comps.xml> file for RPMs that are needed, and
these are added.

=item *

The B<genlist()> function reads the source directories, and finds the
newest RPMs in the source dirs that match the requirements of the
requested RPM.

=item *

Finally, the B<writefiles()> function writes the output files.

=back

=cut

###############################################################################

1;
