#!/usr/bin/perl
# Copyright (C) 2005, 2006, 2007 Christopher Faylor
#
# This software is a copyrighted work licensed under the terms of the
# GNU General Public License.  See http://www.gnu.org/copyleft/gpl.html
# for details.
#
use File::Basename;
use Digest::MD5;
use Getopt::Long;

use strict;

sub mywarn(@);
sub myerror(@);
sub usage();
sub arch_handler(@);

my @okmissing = qw'message ldesc';
my ($outfile, $help, $recursive);
my $arch = 'x86';
my $release;
my @cmp_fmts = qw(gz bz2 lzma xz);

GetOptions('okmissing=s'=>\@okmissing, 'output=s'=>\$outfile, 'help'=>\$help, 'release=s'=>\$release, 'arch=s'=>\&arch_handler, 'recursive'=>\$recursive) or usage;
$help and usage;

@main::okmissing{@okmissing} = @okmissing;

sub arch_handler (@) {
   my ($opt_name, $opt_value) = @_;
   die "invalid arch specified: '$opt_value'"
      unless $main::valid_arch{lc $opt_value};
   $arch = $opt_value;
}

if (defined($outfile)) {
    open(STDOUT, '>', $outfile) or die "$0: can't open $outfile - $!\n";
}

my %pkg;

for my $f (@ARGV) {
    if (-d $f) {
	parsedir($f);
    } else {
	parse($f);
    }
}

print <<'EOF';
# This file is automatically generated.  If you edit it, your
# edits will be discarded next time the file is generated.
# See http://cygwin.com/setup.html for details.
#
EOF

my $ts = time();
print "release: $release\n" if $release;
print "arch: $arch\n";
print "setup-timestamp: $ts\n";
print "$main::setup_version\n" if $main::setup_version;

undef $main::curfile;
for my $p (sort keys %pkg) {
    my $skip = $pkg{$p}{''}{'skip'};
    next if defined($skip);
    print "\n@ $p\n";
    for my $key ('sdesc', 'ldesc', 'category', 'requires', 'message') {
	my $val = $pkg{$p}{''}{$key};
	if (!defined($val) && $pkg{$p}{''}{'install'} !~ /_obsolete/o) {
	    mywarn "package $p is missing a $key field"
	      unless defined $main::okmissing{$key};
	} else {
	    if ($key eq 'requires') {
		for my $p1 (split(' ', $val)) {
		    mywarn "package $p requires an unknown package '$p1'"
		      unless $pkg{$p};
		}
	    } elsif ($key eq 'category') {
		for my $c (split(' ', $val)) {
		    mywarn "package $p uses an invalid category '$c'"
		      unless $main::categories{lc $c};
		}
	    }
	    print "$key: ", $val, "\n" if defined($val) and $val ne "";
	}
    }
    for my $what ('', "[prev]\n", "[test]\n") {
	$pkg{$p}{$what} or next;
	print "$what";
	for my $key ('version', 'install', 'source') {
	    my $val = $pkg{$p}{$what}{$key} or next;
	    print "$key: ", $val, "\n";
	}
    }
}

sub get {
    my $FH = shift;
    my $keyhint = shift;
    my $val = shift;

    if ($keyhint eq 'message') {
	my ($kw, $rest) = $val =~ /^([^"'\s]+)\s+(.*)$/;
	return undef unless defined($kw) && defined($rest);
	return $kw . ' ' . get($FH, 'ldesc', $rest);
    } elsif (substr($val, 0, 1) ne '"') {
	$val = '"'. $val . '"' if $keyhint eq 'ldesc' || $keyhint eq 'sdesc';
    } else {
	while (length($val) == 1 || $val !~ /"$/os) {
	    $_ = <$FH>;
	    length or last;
	    chomp;
	    s/(\S)\s+$/$1/;
	    $val .= "\n" . $_;
	}
    } 
    $val =~ s/(.)"(.)/$1'$2/mog;
    return $val;
}

sub parse {
    my $f = shift;
    my $pname = shift;
    my $what;
    $main::curfile = $f;
    $. = 0;
    open(\*F, '<', $f) or die "$0: couldn't open $f - $!\n";
    while (<F>) {
	chomp;
	s/#.*$//o;
	s/^\s+//o;
	s/(\S)\s+$/$1/o;
	length or next;
	/^setup-timestamp:/ and do {
	    $main::setup_timestamp = $_;
	    next;
	};
	/^setup-version:/ and do {
	    $main::setup_version = $_;
	    next;
	};
	/^arch:/ and do {
	    next;
	};
	/^release:/ and do {
	    next;
	};
	/^skip:/ and do {
	    $pkg{$pname}{''}{'skip'} = 1;
	    next;
	};
	/^\@\s+(\S+)/ and do {
	    $pname = $1;
	    $what = '';
	    next;
	};
	/^([^:]+):\s*(.*)$/ and do {
	    my $key = $1;
	    my $val = $2;
	    if ($key !~ /^(?:prev|curr|test)/) {
		$val = get(\*F, $key, $val);
		$pkg{$pname}{$what}{$key} = $val;
	    } else {
		if ($key eq 'curr') {
		    $key = '';
		} else {
		    $key = "[$key]\n";
		}
		$pkg{$pname}{$key}{'version'} = $val;
	    }
	    next if defined $val;
	};
	/^\[[^\]]+\]/ and do {
	    $what = $_ . "\n";
	    next;
	};
	die "$0: unrecognized input at line file $f, line $.\n";
    }
}

sub parsedir {
    my $d = shift;
    my $pname = basename($d);
    delete $pkg{$pname};
    if ($recursive) {
	for my $drecur (glob("$d/*/.")) {
	    last if $drecur =~ /\*/;
	    parsedir(dirname($drecur));
	}
    }
    my $setup_hint = "$d/setup.hint";
    return unless -e $setup_hint;
    parse("$setup_hint", $pname);
    my $skip = $pkg{$pname}{''}{'skip'};
    return if defined($skip);
    my $explicit = 0;
    for my $what ('', "[prev]\n", "[test]\n") {
	my $x = $pkg{$pname}{$what};
	next unless $x->{'version'};
	$explicit = 1;
	addfiles($pname, $x, $d);
    }

    return if $explicit;
    my $cmp_fmts_grep = join('|', @cmp_fmts);
    my $cmp_fmts_glob = join(',', @cmp_fmts);
    my @files = sort grep{!/-src\.tar\.($cmp_fmts_grep)/} glob("$d/*.tar.{$cmp_fmts_glob}");
    if (!@files) {
	myerror "not enough package files in $d";
	return;
    }
    for my $what ('', "[prev]\n") {
	my $f = pop @files or last;
	$pkg{$pname}{$what}{-unused} = 1;
	my $x = $pkg{$pname}{$what};
	my $p;
	($p, $x->{'version'}) = getver($f);
	addfiles($p, $x, $d);
    }
}

sub addfiles {
    my $pname = shift;
    my $x = shift;
    my $d = shift;
    my $install = tarball($d, $pname, $x->{'version'});
    filer($x, 'install', $install);

    if ($pkg{$pname}{''}{'external-source'}) {
	$pname = $pkg{$pname}{''}{'external-source'};
	$d = finddir($d, $pname) or return;
    }

    my $source  = tarball($d, $pname, $x->{'version'}, 'src');
    filer($x, 'source', $source);
}

sub getver {
    my $f = basename($_[0]);
    my @a = ($f =~ /^(.*?)-(\d.*)\.tar/);
    return wantarray ? @a : $a[1];
}

sub filer {
    my $x = shift;
    my $what = shift;
    my $f = shift;
    open(*F, '<', $f) or do {
	myerror "can't open $f - $!" unless $main::okmissing{$what};
	return undef;
    };
    my $md5 = Digest::MD5->new;
    $md5->addfile(\*F);
    $x->{$what} = join(' ', $f, -s $f, $md5->hexdigest);
}

sub tarball {
    my $d = shift;
    my $b = join('-', @_) . '.tar.';
    for my $e (@cmp_fmts) {
      my $f = "$d/" . "$b" . "$e";
      if (-e "$f") {
        return "$f";
      }
    }
    # default to .bz2 (even though we know it is missing)
    return "$d/" . "$b" . "bz2";
}

sub fnln {
    return $main::curfile ? "$main::curfile:$.: " : '';
}

sub mywarn(@) {
    warn "warning: " . fnln . "@_\n";
}

sub myerror(@) {
    warn "error: " . fnln . "@_\n";
}

sub finddir {
    my $d = $_[0];
    my $pname = $_[1];
    while (($d = dirname($d)) ne '.' && length($d)) {
	return "$d/$pname" if -d "$d/$pname";
    }
    myerror "couldn't find package directory for external-source '$pname'";
    return undef;
}

sub usage() {
    print STDERR <<'EOF';
Usage: genini [--okmissing=key ...] [--recursive] [--output=file] [--help] [setup.ini] [dir ...]
Create cygwin setup.ini from setup.ini, setup.hint and tar ball information.

    --okmissing=key    don't warn if key is missing from setup.ini or setup.hint
                       or if some expected `source' or `install' tarballs are
                       missing. Option may be repeated. --okmissing=install is
                       useful if hint files contain `prev' or `test' entries for
                       missing tarballs. --okmissing=source is useful for
                       LOCAL-ONLY[*] srcless install media.
    --recursive        recurse all subdirectories of specified dirs
    --arch=x86|x86_64  Must be either x86 or x86_64. Defaults to x86.
    --release=string   Optional repository id: cygwin, cygwinports, etc.
    --output=file      output setup.ini info to file
    --help             display this message

[*] You wouldn't want to violate the GPL, now would you?

Report bugs to cygwin mailing list.
EOF
    exit 0;
}

BEGIN {
    my @cats = qw'
     Admin Archive Audio Base Comm Database Debug Devel Doc DotNET Editors
     Games Gnome Graphics Interpreters Java KDE Libs LyX Mail Math Mingw
     Net Perl Publishing Python Ruby Science Shells Sound System Text Tcl
     Utils Video Web X11 _obsolete _PostInstallLast
     ';
    @main::categories{map {lc $_} @cats} = @cats;

    my @archs = qw'x86 x86_64';
    @main::valid_arch{map {lc $_} @archs} = @archs;
}