#!/usr/bin/perl -w
#
# imgtool -- Tool for generating disk images from package lists
# 
# Copyright (C) 2000, Craig Ross and Michael Jennings
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies of the Software, its documentation and marketing & publicity
# materials, and acknowledgment shall be given in the documentation, materials
# and software packages that this Software was used.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
# IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
# CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# $Id: imgtool,v 1.18 2004/06/04 17:16:40 mej Exp $
#

# Include the Perl Modules we need
use POSIX;
use Getopt::Long;
use Mezzanine::Util;

# Print usage information
sub
print_usage_info
{
    print "\n";
    $leader = "$progname $version Usage Information";
    $underbar = $leader;
    $underbar =~ s/./-/g;
    print "$leader\n$underbar\n";
    print "\n";
    print "  Syntax:   imgtool [ options ]\n";
    print "\n";
    print "    -h --help                        Show this usage information\n";
    print "    -d --debug                       Turn on debugging\n";
    print "    -v --version                     Show version and copyright\n";
    print "    -i --image                       Specify the image directory\n";
    print "    -D --dir <directory>             Specify one or more directories from which to take packages\n";
    print "    -a --archive <file>              Create an archive (tarball) of the image when finished\n";
    print "    -l --list <file>                 Take the package list from \"file\" instead of the command line\n";
    print "    -t --test                        Test dependencies but do not install packages\n";
    print "    -k --keep                        Keep the existing root image and add to it\n";
    print "    -f --force                       Do as much as possible despite failures\n";
    print "\n";
    exit(MEZZANINE_SUCCESS);
}

sub
get_package_list
{
    my $filename = $_[0];
    my ($line, $flags);
    my @pkgs;
    local *LISTFILE;

    open(LISTFILE, $filename) || return @pkgs;
    dprint "Reading package list from $filename\n";
    while (<LISTFILE>) {
        $flags = 0;
        chomp($line = $_);
        # Skip comments and empty lines
        next if ($line =~ /^\#/ || $line =~ /^\s*$/);

        # These lines strip leading and trailing whitespace, then grab the contents of
        # the line before any intervening spaces but after any slashes.
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        $line =~ s/^.*\///g;
        dprint "Looking at $line\n";
        if ($line =~ /^\S+\s+(-\S+.*)$/) {
            $flags = $1;
        }
        $line =~ s/^(\S+)\s+.*$/$1/;

        # Skip lines with colons (product variables from product files)
        next if ($line =~ /:/);

        # If we get here, what remains is a package
        dprint "Got package:  $line\n";
        push @pkgs, $line;
        if ($flags) {
            $flags{$line} = $flags;
            dprint "Set flags for $line to $flags{$line}\n";
        }
    }
    close(LISTFILE);
    return @pkgs;
}

sub
find_packages
{
    my @pkgs = @_;
    my (@contents, @rpms);

    foreach my $dir (@pkgdirs) {
        my @tmp;

        @tmp = &grepdir(sub {$_ =~ /\.rpm$/ && $_ !~ /\.(no)?src\.rpm$/}, $dir);
        push @contents, @tmp;
    }

    foreach my $rpm (@contents) {
        my ($pkg, $ver, $rel, $arch);

        $rpm =~ m/^(\S*\/)?([^\/]+)-([^-\/]+)-([^-\/]+)\.(\w+)\.rpm$/;
        ($pkg, $ver, $rel, $arch) = ($2, $3, $4, $5);
        if (!defined($rpm_name{$pkg})) {
            $rpm_name{$pkg} = $rpm;
            $arch{$pkg} = $arch;
        } elsif ($rpm ne $rpm_name{$pkg}) {
            if ($arch ne $arch{$pkg}) {
                my $found = 0;

                foreach my $a (@arch_list) {
                    if ($arch eq $a) {
                        $rpm_name{$pkg} = $rpm;
                        $arch{$pkg} = $arch;
                        $found = 1;
                        last;
                    } elsif ($arch{$pkg} eq $a) {
                        $found = 1;
                        last;
                    }
                }
                next if ($found);
            }
            eprint "Multiple RPM's found for $pkg:  $rpm (new) vs. $rpm_name{$pkg} (old)\n";
            if (-t) {
                my $ans;

                print "Shall I replace the old one with the new one?\n";
                chomp($ans = <STDIN>);
                if ($ans =~ /^\s*y(es)?\s*$/i) {
                    print "Using $rpm for $pkg\n";
                    $rpm_name{$pkg} = $rpm;
                    $arch{$pkg} = $arch;
                } else {
                    print "Ignoring $rpm\n";
                }
            } else {
                print "I will ignore $rpm\n";
            }
        }
    }
}

sub
install_packages
{
    my @pkgs = @_;
    my ($line, $cmd, $rpm, $prog);
    local *CMD;

    if (! $keep) {
        print "Cleaning old image tree....\n";
        &nuke_tree($imagedir);
        &mkdirhier("$imagedir/var/lib/rpm");
        system("rpm --initdb --root=$imagedir");
    }

    foreach my $pkg (@pkgs) {
        if (!defined($rpm_name{$pkg})) {
            if ($force) {
                eprint "No package found for $pkg!\n";
                next;
            } else {
                &fatal_error("No package found for $pkg!\n");
            }
        }
        if ($global_flags) {
            $prog = "--program='rpm $global_flags'";
        } else {
            $prog = "";
        }
        $prog .= " -d" if (&debug_get());
        $rpm = $rpm_name{$pkg};
        $cmd = "pkgtool $prog --root=$imagedir -ip $rpm";

        open(CMD, "$cmd 2>&1 |") || &fatal_error("Unable to execute pkgtool -- $!\n");
        print "Installing $pkg (${\(&basename($rpm))}) into $imagedir....\n";
        dprint "$cmd\n";
        while (<CMD>) {
            chomp($line = $_);
            if ($line =~ /^\[/) {
                dprint "$line\n";
            } elsif ($line !~ /successfully installed/) {
                eprint "$line\n";
            }
        }
        close(CMD);
        if ($? != MEZZANINE_SUCCESS) {
            if ($force) {
                eprint "Install of $rpm failed (error $?).\n";
            } else {
                &fatal_error("Install of $rpm failed (error $?).\n");
            }
        }
    }
    return MEZZANINE_SUCCESS;
}

sub
archive_image
{
    my $filename = $_[0];
    my ($line, $cmd, $prog);
    local *CMD;

    chdir($imagedir);
    if ($filename =~ /\.(tar\.|t)(gz|Z)$/) {
        $cmd = "tar --numeric-owner --use-compress-program=gzip -Pcf $filename .";
    } elsif ($filename =~ /\.(tar\.|t)\.bz2?$/) {
        $cmd = "tar --numeric-owner --use-compress-program=bzip2 -Pcf $filename .";
    }

    if (!open(CMD, "$cmd 2>&1 |")) {
        if ($force) {
            eprint "Unable to execute \"$cmd\" -- $!\n";
            return;
        } else {
            &fatal_error("Unable to execute \"$cmd\" -- $!\n");
        }
    }
    print "Creating archive file $filename from $imagedir....\n";
    dprint "$cmd\n";
    while (<CMD>) {
        chomp($line = $_);
        if ($line =~ /^tar:/) {
            eprint "$line\n";
        }
    }
    close(CMD);
    if ($?) {
        if ($force) {
            eprint "Creation of archive file failed.\n";
        } else {
            &fatal_error("Creation of archive file failed.\n");
        }
    }
}

# main() here is basically the same as main() in C
sub
main
{
    # Set up the basic variables
    $progname = "imgtool";
    $version = "2.1";
    &print_usage_info() if (!scalar(@ARGV));
    umask 022;

    # See the Getopt::Long man page for details on the syntax of this line
    @valid_opts = ("h|help", "v|version", "d|debug", "i|image=s", "D|dir=s", "a|archive=s",
                   "l|list=s", "t|test", "k|keep", "A|arch=s", "f|force");
    Getopt::Long::Configure("no_getopt_compat", "bundling", "no_ignore_case");
    Getopt::Long::GetOptions(@valid_opts);

    # Post-parse the options stuff
    select STDOUT; $| = 1;
    if ($opt_v) {
        # Do not edit this variable.  It is updated automatically by CVS when you commit
        my $rcs_info = 'CVS Revision $Revision: 1.18 $ created on $Date: 2004/06/04 17:16:40 $ by $Author: mej $ ';

        $rcs_info =~ s/\$\s*Revision: (\S+) \$/$1/;
        $rcs_info =~ s/\$\s*Date: (\S+) (\S+) \$/$1 at $2/;
        $rcs_info =~ s/\$\s*Author: (\S+) \$ /$1/;
        print "\n";
	print "$progname $version by Michael Jennings <mej\@eterm.org>\n";
        print "Copyright (c) 2000, Michael Jennings\n";
        print "  ($rcs_info)\n";
        print "\n";
	return MEZZANINE_SUCCESS;
    } elsif ($opt_h) {
	&print_usage_info();   # Never returns
    }

    &debug_set($opt_d);
    $imagedir = ($opt_i ? $opt_i : ($ENV{"MEZZANINE_IMAGEDIR"} ? $ENV{"MEZZANINE_IMAGEDIR"} : "./img"));
    mkdir($imagedir, 0700) if (! -d $imagedir);
    $imagedir = abs_path($imagedir);
    if ($opt_D) {
        @pkgdirs = split(/[:\s]/, $opt_D);
    } elsif ($ENV{MEZZANINE_BUILDDIR}) {
        @pkgdirs = glob('$ENV{MEZZANINE_BUILDDIR}/RPMS/*');
    } else {
        @pkgdirs = glob('build.mezzanine/RPMS/*');
    }
    $keep = ($opt_k ? 1 : 0);
    $force = ($opt_f ? 1 : 0);
    $global_flags = ($opt_t ? "--justdb --noscripts --notriggers --force --nodeps" : "--force --nodeps");
    $archive = ($opt_a ? $opt_a : "");
    if ($archive && $archive !~ /^\//) {
        $archive = &getcwd() . "/$archive";
    }
    if ($opt_l) {
        @pkgs = &get_package_list($opt_l);
    } else {
        @pkgs = @ARGV;
    }
    if ($opt_A) {
        @arch_list = split(/[ ,:\|]/, $opt_A);
    } else {
        @arch_list = ("i386", "noarch", "i586", "i686");
    }
    dprint "Creating image $imagedir ", ($archive ? "and tarball $archive " : ""), "from packages in $opt_l\n";

    # Oops-proofing
    if ($imagedir eq "/" && ! $keep) {
        &fatal_error("Sorry, I refuse to remove /.\n");
    }

    # Signal handling
    $SIG{HUP} = 'IGNORE';
    $SIG{INT} = \&handle_signal;
    $SIG{TERM} = \&handle_signal;
    $SIG{QUIT} = \&handle_fatal_signal;
    $SIG{ILL} = \&handle_fatal_signal;
    $SIG{ABRT} = \&handle_fatal_signal;
    $SIG{FPE} = \&handle_fatal_signal;
    $SIG{SEGV} = \&handle_fatal_signal;
    $SIG{BUS} = \&handle_fatal_signal;
    $SIG{TSTP} = \&handle_fatal_signal;
    $SIG{TTIN} = \&handle_fatal_signal;
    $SIG{TTOU} = \&handle_fatal_signal;

    &find_packages(@pkgs);
    &install_packages(@pkgs);
    &archive_image($archive) if ($archive);
    return MEZZANINE_SUCCESS;
}

exit &main();
