#!/usr/bin/perl 

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell
#
# rpmgrill-analyze-local - run rpmgrill on local RPMs
#
# $Id$
#
package RPM::Grill::Analyze::Local;

use strict;
use warnings;

(our $ME = $0) =~ s|.*/||;
(our $VERSION = '$Revision: 0.0 $ ') =~ tr/[0-9].//cd;

# For debugging, show data structures using DumpTree($var)
#use Data::TreeDumper; $Data::TreeDumper::Displayaddress = 0;

###############################################################################
# BEGIN user-customizable section


# END   user-customizable section
###############################################################################

use Cwd                         qw(getcwd);
use File::Basename;
use File::Copy                  qw(copy);
use File::Path                  qw(make_path remove_tree);
use File::Temp                  qw(tempdir);

# Needed so we can load rpmgrill-fetch-build utility script
use FindBin;
use lib $FindBin::Bin;

###############################################################################
# BEGIN boilerplate args checking, usage messages

sub usage {
    print  <<"END_USAGE";
Usage: $ME [OPTIONS] RPM [RPM...] [BUILDLOG]

$ME is a simple front-end wrapper allowing rpmgrill to
perform simple (incomplete) analysis on locally-built RPMs.

Example:

    \$ $ME foo-1.2-3.fc20.*.rpm foo.log

rpmgrill results will be in files named rpmgrill-<NVR>.* written
by default in the current directory, e.g.:

     rpmgrill-foo-1.2-3.fc20.{json,xml,yaml}

Parsing and interpreting those results is left as an exercise
for the reader.

OPTIONS:

  --results-dir=DIR  write rpmgrill results into DIR (default: .)
  --keep-tmpdir      preserve working directory on exit

  -v, --verbose      show verbose progress indicators

  --help             display this message
  --man              display program man page
  --version          display program name and version
END_USAGE

    exit;
}

sub man {
    # Read the POD contents.  If it hasn't been filled in yet, abort.
    my $pod = do { local $/; <DATA>; };
    if ($pod =~ /=head1 \s+ NAME \s+ FIXME/xm) {
        warn "$ME: No man page available.  Please try $ME --help\n";
        exit;
    }

    # Use Pod::Man to convert our __DATA__ section to *roff
    eval { require Pod::Man }
        or die "$ME: Cannot generate man page; Pod::Man unavailable: $@\n";
    my $parser = Pod::Man->new(name => $ME, release => $VERSION, section => 1);

    # If called without output redirection, man-ify.
    my $out_fh;
    if (-t *STDOUT) {                           ## no critic
        my $pager = $ENV{MANPAGER} || $ENV{PAGER} || 'less';
        open $out_fh, "| nroff -man | $pager";  ## no critic
    }
    else {
        open $out_fh, '>&STDOUT';               ## no critic
    }

    # Read the POD contents, and have Pod::Man read from fake filehandle.
    # This requires 5.8.0.
    open my $pod_handle, '<', \$pod;
    $parser->parse_from_filehandle($pod_handle, $out_fh);
    exit;
}


# Command-line options.  Note that this operates directly on @ARGV !
our $results_dir = '.';         # Where to write rpmgrill results
our $opt_keep;                  # Don't delete our tmpdir on exit
our $debug   = 0;
our $force   = 0;
our $verbose = 0;
sub handle_opts {
    use Getopt::Long;
    GetOptions(
        'results-dir=s' => \$results_dir,
        'keep-tmpdir'   => \$opt_keep,

        'debug!'     => \$debug,
        'force'      => \$force,
        'verbose|v'  => \$verbose,

        help         => \&usage,
        man          => \&man,
        version      => sub { print "$ME version $VERSION\n"; exit 0 },
    ) or die "Try `$ME --help' for help\n";
}

# END   boilerplate args checking, usage messages
###############################################################################

############################## CODE BEGINS HERE ###############################

# The term is "modulino".
__PACKAGE__->main()                                     unless caller();

# Main code.
sub main {
    # Note that we operate directly on @ARGV, not on function parameters.
    # This is deliberate: it's because Getopt::Long only operates on @ARGV
    # and there's no clean way to make it use @_.
    handle_opts();                      # will set package globals

    # Sanity check: results directory must exist
    -e $results_dir
        or die "$ME: Results directory '$results_dir' does not exist\n";
    -d $results_dir
        or die "$ME: Results directory '$results_dir' is not a directory!\n";

    die "$ME: No arguments given; try $ME --help\n" if !@ARGV;

    # Parse command-line args; these must be one or more RPMs and logs
    my @infiles = handle_args(@ARGV);

    # From our input files, make a guess at a package NVR
    my $nvr = guess_nvr(@infiles);
    print "[$ME: NVR is $nvr]\n"                        if $debug;


    # Create a temporary working directory. This will be used to
    #   1) Hold copies of the rpms and build logs in one place; and
    #   2) unpack the rpms, for rpmgrill to work on
    my $tmpdir = tempdir( "$ME.XXXXXXX", TMPDIR => 1, CLEANUP => 0 );

    # Copy all our input args into a holding directory
    $ENV{RPMGRILL_FETCH_BUILD_CACHE} = "$tmpdir/cache";
    print " [copying RPMs to $tmpdir/cache]\n"                  if $verbose;
    make_cache_dir("$tmpdir/cache/$nvr", @infiles);

    print " [unpacking RPMs]\n"                                 if $verbose;
    my $workdir = unpack_rpms_and_logs($nvr, $tmpdir, @infiles);

    # Finally, invoke rpmgrill
    my @cmd = ('rpmgrill', $workdir);
    print " [running: @cmd]\n"                                  if $verbose;
    system(@cmd) == 0
        or die "$ME: command failed: @cmd\n";

    # rpmgrill leaves us with results in the form of "rpmgrill.*" files
    # in the working directory. Move those into the desired directory,
    # renaming so as to include the NVR.
    my @results = glob("$workdir/rpmgrill.*")
        or die "$ME: FATAL: No results found ($workdir/rpmgrill.*)\n";
    for my $path (@results) {
        (my $dest = basename($path)) =~ s|^(rpmgrill)\.([^/]+)$|$1-$nvr.$2|
            or die "$ME: INTERNAL ERROR: Unexpected filename '$path'";
        $dest = "$results_dir/$dest";

        unlink                   "$dest.BAK";   # Remove old backup, if any
        rename          $dest => "$dest.BAK";   # Preserve backup, if applicable
        copy   $path => $dest;
    }

    print "$ME: Results are in $results_dir/rpmgrill-$nvr.*\n"  if $verbose;

    # Clean up extracted RPMs
    remove_tree($tmpdir)                                unless $opt_keep;
}

#######################
#  handle_input_args  #  Parse RPMs and build logs from command-line input
#######################
#
# ...returns a list of HREFs containing { path, type, arch }
sub handle_args {
    my (@rpms, @logs);                  # for gathering return values
    my %arch_seen;

    for my $rpm_or_log (@_) {
        if ($rpm_or_log =~ /\.(\w+)\.rpm$/) {
            my $arch = $1;
            $arch_seen{$arch}++;
            push @rpms, { path => $rpm_or_log, arch => $arch };
        }

        elsif ($rpm_or_log =~ /\.log\b/) {
            push @logs, { path => $rpm_or_log, arch => undef };
        }

        else {
            die "$ME: Unrecognized input file '$rpm_or_log'; I can only handle *.rpm or *.log\n";
        }
    }

    #
    # Done with input files. Perform cross-checks.
    #
    @logs
        or warn "$ME: WARNING: Invoked without build log; some tests will not run\n";

    delete $arch_seen{src}
        or warn "$ME: WARNING: Invoked without SRPM; some tests will not run\n";
    my @arches = sort keys %arch_seen
        or die "$ME: FATAL: Invoked with no built RPMs; this is pointless.\n";

    # Figure out the arch for the log file. Try for a real arch first,
    # but fall back to noarch
    my @log_arch = ((grep { $_ ne 'noarch' } @arches), 'noarch');
    $_->{arch} = $log_arch[0]       for @logs;


    return ((map { $_->{type} = 'rpm'; $_ } @rpms),
            (map { $_->{type} = 'log'; $_ } @logs));
}

###############################################################################
# BEGIN helpers for extracting RPMs

####################
#  make_cache_dir  #  Copy RPMs and logs into a cache for rpmgrill-fetch-build
####################
sub make_cache_dir {
    my $cache_dir = shift;                      # in: dir to create
    my @files = @_;                             # in: files to put in it

    make_path($cache_dir, { mode => 0755 })     ## no critic
        or die "$ME: Could not mkdir $cache_dir: $!\n";
    for my $file (@files) {
        my $path = $file->{path};
        my $destname = basename($path);

        # Special case: build logs must be named 'build.log.<arch>' for
        # rpmgrill-fetch-build to see them in the cache dir
        if ($file->{type} eq 'log') {
            $destname = "build.log.$file->{arch}";
        }

        # Try a hardlink first, to save space/speed. But that's likely
        # to fail if we use $TMPDIR, so fall back gracefully to File::Copy
        link($path => "$cache_dir/$destname")
            || copy($path => "$cache_dir/$destname")
            || die "$ME: Could not copy $path to $cache_dir";
    }
}


##########################
#  unpack_rpms_and_logs  #  Unpack a set of RPMs and log files, for rpmgrill
##########################
#
# We've established the framework for a cache directory in the form
# expected by rpmgrill-fetch-build; now let it do the unpacking.
#
sub unpack_rpms_and_logs {
    my $nvr     = shift;                # in: NVR
    my $tmpdir  = shift;                # in: where to create our workdir
    my @infiles = @_;

    require('rpmgrill-fetch-build');

    # Prepare an object containing the basenames of our RPMs.
    # FIXME: this requires knowledge of rpmgrill-fetch-build internals!
    # ...but fixing that would require defining an API. Too much work.
    my $buildinfo = bless {
        build => $nvr,
        rpms  => [ map  { basename($_->{path}) }
                   grep { $_->{type} eq 'rpm' } @infiles],
        # Note that we do not include logs. do_unpack() will find and copy
        # those automatically based on the log file name.
    }, 'Koji::Build';

    # do_unpack() changes directory! Make sure we restore context.
    my $cwd = getcwd;

    # Unpack into a directory for rpmgrill. do_unpack() will die on error.
    my $workdir = "$tmpdir/workdir";
    RPM::Grill::FetchBuild::do_unpack($buildinfo, $workdir);

    chdir $cwd;
    return $workdir;
}

# END   helpers for extracting RPMs
###############################################################################
# BEGIN helpers for extracting NVR

###############
#  guess_nvr  #  From a list of input RPMs, try to guess an NVR
###############
sub guess_nvr {
    if (my @rpms = grep { $_->{type} eq 'rpm' } @_) {
        if (my @srpm = grep { $_->{arch} eq 'src' } @rpms) {
            return extract_nvr_from_path($srpm[0]->{path});
        }
        return extract_nvr_from_path($rpms[0]->{path});
    }

    # No RPMs
    return "unknown-0.0-0";
}

###########################
#  extract_nvr_from_path  #  Given an RPM path name, return the NVR
###########################
sub extract_nvr_from_path {
    my $path = shift;

    $path =~ s|^.*/||;                  # Filter out directory components

    $path =~ /^(.*-.*-.*)\.[^.]+\.rpm$/
        or die "$ME: FATAL: RPM name '$path' is not of the form 'N-V-R.arch.rpm'\n";
    return $1;
}

# END   helpers for extracting NVR
###############################################################################

1;

__DATA__

###############################################################################
#
# Documentation
#

=head1	NAME

rpmgrill-analyze-local - run rpmgrill on locally-built RPMs

=head1	SYNOPSIS

rpmgrill-analyze-local  [B<--verbose>] RPM-OR-LOGFILE [...]

rpmgrill-analyze-local  B<--help>  |  B<--version> | B<--man>

=head1	DESCRIPTION

B<rpmgrill-analyze-local> is a simple front end to B<rpmgrill>,
intended for quick-and-dirty use by developers on local builds.

=head1	OPTIONS

=over 4

=item B<--results-dir=DIR>

Write rpmgrill results into B<DIR> instead of the current directory.
DIR must exist.

=item B<--keep-tmpdir>

rpmgrill-analyze-local unpacks RPMs into a temporary working
directory under C<$TMPDIR>. This is what B<rpmgrill> works on.
Use this option if you need to debug or just peek at internals.

=item B<--verbose>

Show progress messages.

=item B<--help>

Emit usage hints.

=item B<--version>

Display program version.

=item B<--man>

Display this man page.

=back


=head1	DIAGNOSTICS

FIXME

=head1	ENVIRONMENT

C<$TMPDIR> : rpmgrill-analyze-local will create a temporary subdirectory
here, then unpack RPMs in the way B<rpmgrill> expects.

=head1	FILES

rpmgrill-analyze-local copies rpmgrill's results into files named
B<rpmgrill-N-V-R.TYPE> in your current directory (or as specified
with --results-dir option), where B<N-V-R>
is the name-version-release of your package and B<TYPE> is one
of C<json>, C<xml>, or C<yaml>. All are equivalent; multiple
forms are provided as a convenience for the end user.

=head1	RESTRICTIONS

You must provide, at the very least, a SRPM and a built RPM.
It is nonsensical to invoke rpmgrill with just a SRPM or just
a built RPM.

=head1	SEE ALSO

L<rpmgrill|rpmgrill>

=head1	AUTHOR

Ed Santiago <santiago@redhat.com>

=cut
