#!/usr/bin/perl -w

=head1 NAME

    rf - RepomanFrontend

=head1 DESCRIPTION

rf operates with actions, namely, Record, Cleanup, Push, Upload, cL.
If you don't specify non of these actioons, with the marked switch
(eg. for repoman cl it is -L), -RCPUL will be used.
it is trying to guess as many data as needed for the specified
actions, or you can pass them with non capital swithes.
Usually -f and -s are enough to do a whole upgrade.
Run it from the packages darcs directory.
    
=head1 OPTIONS
    
=over 1

=head2 ACTIONS

=item B<-H>

runs a FrugalBuild checking, before recording.
Can be overridden, with actions -RCPUL

=item B<-R>

    darcs record your patch

=item B<-C>

    Cleanup on the server

=item B<-P>

    darcs push your patch

=item B<-U>

    Upload the given source and package files

=item B<-L>

    repoman cl aka generate the Changelog file

=item B<-W>

    A warning message before doing anything

=item B<-h>

    Help

=item B<-r>

    Specify the repository eg. extra
    if not given, default will be used.

=item B<-a>

    Architecture, default is i686.

=item B<-o>

    The directory of the repo, where the fpms are.
    Default is frugalware-$arch.

=item B<-p>

    Serverprefix, eg. 
    ftp://ftp.frugalware.org/pub/frugalware/frugalware-current/ 
    also this is the default.

=item B<-g>

    Group of the package, meaning the physical group, eg. the 
    /extra/devel/adevelpkg has devel group.

=item B<-m>

    Don't run fblint.

=item B<-n>

    Name of the package

=item B<-t>

    Version if the package

=item B<-l>

    Release of the package

=item B<-s>

    New sourcefile

=item B<-f>

    New packagefile

=item B<-q>

    Do not look for old source and package.
    Useful when you contribute a new package.

=item B<-v>

    Version of the distribution, default is current.

=item B<-d> 
    
    Delete the files given in -s and -f

=item B<-c>

    Try to delete the sources, too.
    
=item B<-k>

    Answer yes to all questions.

=head1 CHANGES

=head2 0.6

Release as stable
darcs and -k bugfix
new getopts method - but still not good enough!
fblint check
nobuild option handling
use of 'repoman ls'
more little bugfixes

=head2 0.5

    Release as stable
    pkgver and pkgrel gathering bugfix
    New 'a' keyselection
    More options in man page

=head2 0.4

    Action driven usage
    $arch fixes

=head2 0.3

    Sourcefile must contain 'tar'.
    Inform of use of -d
    asking done with readkey - no more enter hit

=head1 BUGS

    Report bugs, patches, comments, patches and 
    funny quotes in your signature to
    <frugalware-devel@frugalware.org>

=head1 AUTHOR

    Zsolt Szalai <xbit@frugalware.org>

=head1 COPYRIGHT

    rf may be copied and modified under the terms of the 
    GNU General Public License v2

=cut


package Getopts;
require 5.000;
require Exporter;

=head1 NAME

getopt, getopts - Process single-character switches with switch clustering

=head1 SYNOPSIS

    use Getopts;

    getopt('oDI');    # -o, -D & -I take arg.  Sets $opt_* as a side effect.
    getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts
    getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
		      # Sets $opt_* as a side effect.
    getopts('oif:', \%opts);  # options as above. Values in %opts

=head1 DESCRIPTION

The getopt() function processes single-character switches with switch
clustering.  Pass one argument which is a string containing all switches
that take an argument.  For each switch found, sets $opt_x (where x is the
switch name) to the value of the argument if an argument is expected,
or 1 otherwise.  Switches which take an argument don't care whether
there is a space between the switch and the argument.

The getopts() function is similar, but you should pass to it the list of all
switches to be recognized.  If unspecified switches are found on the
command-line, the user will be warned that an unknown option was given.

Note that, if your code is running under the recommended C<use strict
'vars'> pragma, you will need to declare these package variables
with "our":

    our($opt_x, $opt_y);

For those of you who don't like additional global variables being created, getopt()
and getopts() will also accept a hash reference as an optional second argument. 
Hash keys will be x (where x is the switch name) with key values the value of
the argument or 1 if no argument is specified.

To allow programs to process arguments that look like switches, but aren't,
both functions will stop processing switches when they see the argument
C<-->.  The C<--> will be removed from @ARGV.

=head1 C<--help> and C<--version>

If C<-> is not a recognized switch letter, getopts() supports arguments
C<--help> and C<--version>.  If C<main::HELP_MESSAGE()> and/or
C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
the output file handle, the name of option-processing package, its version,
and the switches string.  If the subroutines are not defined, an attempt is
made to generate intelligent messages; for best results, define $main::VERSION.

If embedded documentation (in pod format, see L<perlpod>) is detected
in the script, C<--help> will also show how to access the documentation.

Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
isn't true (the default is false), then the messages are printed on STDERR,
and the processing continues after the messages are printed.  This being
the opposite of the standard-conforming behaviour, it is strongly recommended
to set $Getopt::Std::STANDARD_HELP_VERSION to true.

One can change the output file handle of the messages by setting
$Getopt::Std::OUTPUT_HELP_VERSION.  One can print the messages of C<--help>
(without the C<Usage:> line) and C<--version> by calling functions help_mess()
and version_mess() with the switches string as an argument.

=cut

@ISA = qw(Exporter);
@EXPORT = qw(getopt getopts);
$VERSION = '1.05';
# uncomment the next line to disable 1.03-backward compatibility paranoia
# $STANDARD_HELP_VERSION = 1;

# Process single-character switches with switch clustering.  Pass one argument
# which is a string containing all switches that take an argument.  For each
# switch found, sets $opt_x (where x is the switch name) to the value of the
# argument, or 1 if no argument.  Switches which take an argument don't care
# whether there is a space between the switch and the argument.

# Usage:
#	getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.

sub getopt (;$$) {
    my ($argumentative, $hash) = @_;
    $argumentative = '' if !defined $argumentative;
    my ($first,$rest);
    local $_;
    local @EXPORT;

    while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
	($first,$rest) = ($1,$2);
	if (/^--$/) {	# early exit if --
	    shift @ARGV;
	    last;
	}
	if (index($argumentative,$first) >= 0) {
	    if ($rest ne '') {
		shift(@ARGV);
	    }
	    else {
		shift(@ARGV);
		$rest = shift(@ARGV);
	    }
	    if (ref $hash) {
	        $$hash{$first} = $rest;
	    }
	    else {
	        ${"opt_$first"} = $rest;
	        push( @EXPORT, "\$opt_$first" );
	    }
	}
	else {
	    if (ref $hash) {
	        $$hash{$first} = 1;
	    }
	    else {
	        ${"opt_$first"} = 1;
	        push( @EXPORT, "\$opt_$first" );
	    }
	    if ($rest ne '') {
		$ARGV[0] = "-$rest";
	    }
	    else {
		shift(@ARGV);
	    }
	}
    }
    unless (ref $hash) { 
	local $Exporter::ExportLevel = 1;
	import Getopts;
    }
}

sub output_h () {
  return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
  return \*STDOUT if $STANDARD_HELP_VERSION;
  return \*STDERR;
}

sub try_exit () {
    exit 0 if $STANDARD_HELP_VERSION;
    my $p = __PACKAGE__;
    print {output_h()} <<EOM;
  [Now continuing due to backward compatibility and excessive paranoia.
   See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
EOM
}

sub version_mess ($;$) {
    my $args = shift;
    my $h = output_h;
    if (@_ and defined &main::VERSION_MESSAGE) {
	main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
    } else {
	my $v = $main::VERSION;
	$v = '[unknown]' unless defined $v;
	my $myv = $VERSION;
	$myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
	my $perlv = $];
	$perlv = sprintf "%vd", $^V if $] >= 5.006;
	print $h <<EOH;
$0 version $v calling Getopt::Std::getopts (version $myv),
running under Perl version $perlv.
EOH
    }
}

sub help_mess ($;$) {
    my $args = shift;
    my $h = output_h;
    if (@_ and defined &main::HELP_MESSAGE) {
	main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
    } else {
	my (@witharg) = ($args =~ /(\S)\s*:/g);
	my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
	my ($help, $arg) = ('', '');
	if (@witharg) {
	    $help .= "\n\tWith arguments: -" . join " -", @witharg;
	    $arg = "\nSpace is not required between options and their arguments.";
	}
	if (@rest) {
	    $help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
	}
	my ($scr) = ($0 =~ m,([^/\\]+)$,);
	print $h <<EOH if @_;			# Let the script override this

Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
EOH
	print $h <<EOH;

The following single-character options are accepted:$help

Options may be merged together.  -- stops processing of options.$arg
EOH
	my $has_pod;
	if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
	     and open my $script, '<', $0 ) {
	    while (<$script>) {
		$has_pod = 1, last if /^=(pod|head1)/;
	    }
	}
	print $h <<EOH if $has_pod;

For more details run
	perldoc -F $0
EOH
    }
}

# Usage:
#   getopts('a:bc');	# -a takes arg. -b & -c not. Sets opt_* as a
#			#  side effect.

sub getopts ($;$) {
    my ($argumentative, $hash) = @_;
    my (@args,$first,$rest,$exit,$next);
    my $errs = 0;
    local $_;
    local @EXPORT;

    @args = split( / */, $argumentative );
    while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
	($first,$rest) = ($1,$2);
	if (/^--$/) {	# early exit if --
	    shift @ARGV;
	    last;
	}
	my $pos = index($argumentative,$first);
	if ($pos >= 0) {
	    if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
		shift(@ARGV);
		if ($rest eq '') {
		    ++$errs unless @ARGV;
#		    $rest = shift(@ARGV);
		    while (@ARGV && ($next = shift(@ARGV)) !~ /^(-.)/) {$rest .= $next . ' ';}
		    chop $rest;
		    unshift @ARGV, $next;
		}
		if (ref $hash) {
		    $$hash{$first} = $rest;
		}
		else {
		    ${"opt_$first"} = $rest;
		    push( @EXPORT, "\$opt_$first" );
		}
	    }
	    else {
		if (ref $hash) {
		    $$hash{$first} = 1;
		}
		else {
		    ${"opt_$first"} = 1;
		    push( @EXPORT, "\$opt_$first" );
		}
		if ($rest eq '') {
		    shift(@ARGV);
		}
		else {
		    $ARGV[0] = "-$rest";
		}
	    }
	}
	else {
	    if ($first eq '-' and $rest eq 'help') {
		version_mess($argumentative, 'main');
		help_mess($argumentative, 'main');
		try_exit();
		shift(@ARGV);
		next;
	    } elsif ($first eq '-' and $rest eq 'version') {
		version_mess($argumentative, 'main');
		try_exit();
		shift(@ARGV);
		next;
	    }
	    warn "Unknown option: $first\n";
	    ++$errs;
	    if ($rest ne '') {
		$ARGV[0] = "-$rest";
	    }
	    else {
		shift(@ARGV);
	    }
	}
    }
    unless (ref $hash) { 
	local $Exporter::ExportLevel = 1;
	import Getopts;
    }
    $errs == 0;
}

package main;

use strict;
no warnings qw(uninitialized);

use Data::Dumper;
use LWP::Simple;
use Cwd;
#use Getopts;
use Term::ReadLine;
use IO::File;
eval {require Term::ReadLine::Gnu}; die 'Please install perl-term-readline-gnu!' if $@;
eval {require Term::ReadKey}; die 'Please install perl-term-readkey!' if $@;
import Term::ReadKey;

#$Getopt::Std::STANDARD_HELP_VERSION = 1;
our $VERSION = "0.6";

sub HELP_MESSAGE(){
  print <<END
	rf [-RCPULH] [-s source1 source2 ...] [-f package1 package2] [-d] [-q] [-k] [-n name]
END
}

sub contents {
    my $name = shift;
    unless (-e $name || -r $name) {
      die "No $name found, or don't have the rights. Are you in a package's directory?";
    }
    my $sfh = IO::File->new( "< $name" );
    local $/ = undef;
    my $cont = $sfh->getline;
    $sfh->close;
    return $cont;
}

my $chkonce = 0;
my %opts;
Getopts::getopts('chmr:a:o:p:g:n:s:f:v:dqkt:l:WRCPULH', \%opts);

HELP_MESSAGE && die if $opts{h};

$opts{R}=$opts{C}=$opts{P}=$opts{U}=$opts{L}=$opts{H} = 1 unless $opts{R}|| $opts{C}||$opts{P}||$opts{U}||$opts{L}||$opts{H};
$chkonce = 1 if $opts{m};

my ($distrib,$version,$repo,$arch, $repodir, $serverprefix, $group, $pkgname, $noask) =
    ('frugalware',$opts{v},undef,$opts{a}, $opts{o}, $opts{p}, $opts{g}, $opts{n}, $opts{k});

my @sourcefiles = split ' ', $opts{'s'};
my @pkgfiles = split ' ', $opts{'f'};
my ($pkgver, $pkgrel);

sub msystem{
    system @_;
    warn 'Failed to execute!' if $? == -1;
    return $?>>8;
}

sub getcommand{
    my $str = shift;
    my $term = new Term::ReadLine 'getcommand';
    return $term->readline('>',$str)
}

sub ask{
    my $str = shift;
    return 'y' if $noask;
    print "$str ";
    my $key;
    ReadMode(4);
    $key = ReadKey();
    ReadMode(0);
    print "$key\n";
    return $key;
}

sub apply{
    my $comm = shift;
    my $exitcode;
 APP:
    if ((my $an = ask "$comm\n Is this ok? [yagq?]") =~ /^y|^$/i){
	$exitcode = msystem $comm;
    } elsif ($an =~ /^a/i){
	$noask = 1;
	$exitcode = msystem $comm;
    } elsif ($an =~ /^g/i){
	$exitcode = msystem getcommand($comm);
    } elsif ($an =~ /^q/i){
	exit;
    } elsif ($an =~ /^\?/){
	print "y apply command\na: yes to all further question\ng: give a new command\nq: quit\n\n";
	undef $an;
	goto APP;
  }
    print "\n";
    return $exitcode;
}

$repo = '' || $opts{r};
$repo = 'extra' if getcwd =~ m!/extra/!;

$version = 'current' unless $version; #no need :)
$arch = qx/arch/ and chomp $arch unless $arch;

$repodir = "$distrib-$arch" unless $repodir;
$serverprefix = "ftp://ftp.$distrib.org/pub/$distrib/$distrib-$version/";

unless ( ($group) = getcwd =~ m!.*/(.*?)/[^/]*\Z! ){
    $group = $opts{g};
}
HELP_MESSAGE && die 'No physical group given!' unless $group;

($pkgname) = getcwd =~ m!/([^/]*)\Z! unless $pkgname;

#unless ($pkgname) {($pkgname)= $pkgfiles[0] =~ /^(.*)-.*?-.*?-.*?fpm\Z/{
  
HELP_MESSAGE && die 'Can not determine pkgname!' unless $pkgname;

my $buildscript = contents 'FrugalBuild';

$opts{L} = 0 if $buildscript =~ /^nobuild=|^options.*?nobuild/m;

$buildscript = contents 'FrugalBuild';
($pkgver) = qx'source /usr/lib/frugalware/fwmakepkg;source ./FrugalBuild; echo -n $pkgver';
($pkgrel) = qx'source /usr/lib/frugalware/fwmakepkg;source ./FrugalBuild; echo -n $pkgrel';

($pkgver,$pkgrel) = $pkgfiles[0] =~ /^.*-(.*?)-(.*?)-.*?fpm\Z/ unless $pkgver || $pkgrel;

$pkgver = $opts{t} if $opts{t};
$pkgrel = $opts{l} if $opts{l};

my $subg = 0;
if ($buildscript =~ /subgroup.*?-extra/m) {$subg++;}

sub getoldsource{
#OBSOLETE
    my ($url,$sourcefile)= @_;
    my ($sn) = $sourcefile =~ /(.*)-/;
    if (get($url) =~ /(\Q$sn\E.*?tar.*?)\s/) {
	return $1;
    }
    return 0;
}

sub getoldfpm{
    my ($url,$pkgname)= @_;
    if (qx"repoman -t $version ls $repo/$repodir" =~ /^(\Q$pkgname\E-[^-]*?-[^-]*?-[^-]*?fpm)\s/sm) {
	return $1;
    }
    return 0;
}

sub ChkFB {
 return 0 if $chkonce;
 $chkonce = 1 unless $chkonce;	# dont want to see suck a thing!
 print "Checking FrugalBuild... ";
 my @fblint = grep {/\.\.\. failed./} qx/fblint/;
 do { print "\n", @fblint; return 1; } if @fblint;
 print "Ok\n"; return 0;
}

sub Record{
  die if ChkFB;
  print "Recording your improvements\n";
  HELP_MESSAGE && die 'Can not determine pkgver!' unless $pkgver;
  HELP_MESSAGE && die 'Can not determine pkgrel!' unless $pkgrel;
  my $ec = apply "darcs record --edit-long-comment -m '$pkgname-$pkgver-$pkgrel-$arch'" . ($noask? ' -a' : '').' .';
  die "Recording FAILED!\n" if $ec == 1;
}

sub Push{
  print "Pushing the patch\n";
  my $modpkgname = $pkgname;
  $modpkgname =~ s/\+/\\\+/g;
  my $ec = apply "darcs push --match 'name $modpkgname'" . ($noask? ' -a' : '');
  die "Pushing FAILED!\n" if $ec == 1;
}

sub Upload{
    my ($ec,$ev);
    print "Uploading source and binary package\n";
    print "Nothing to do, that's fine!\n\n" unless @sourcefiles;
    for my $sourcefile (@sourcefiles){
	$ec = apply "repoman -t $version up $sourcefile $repo/source/$group/$pkgname/" if $sourcefile;
    }
    print "Nothing to do, that's fine!\n\n" unless @pkgfiles;
    for my $pkgfile (@pkgfiles){
	#my $repo_ = "extra" if(qx/LANG= LC_ALL= pacman -Qi -p $pkgfile/ =~ /Groups.*-extra/);
	$ev = apply "repoman -t $version up $pkgfile /$repodir/" if $pkgfile;
  }
    die "Uploading FAILED!" if $ev || $ec;
}

sub cL{
  print "Generating ChangeLog\n";
  $repo.='/' if $repo;
  my $ec = apply "arch=$arch repoman -t $version cl $repo$group/$pkgname";
  die "Changelog not generated!" if $ec;
}

sub Cleanup{
    my ($ec,$ev,$ir);
    unless ($opts{'q'}){
	if ($opts{'c'}){
	    print "Cleanup on server\n";
	    my $repo_=$repo . '/' if $repo;
	    #    print "Nothing to do, that's fine!\n\n" unless @sourcefiles || @pkgfiles;
	    #    if (@sourcefiles){
	    my (@indarcs) = qx"repoman -t $version ls _darcs/current/$repo_/source/$group/$pkgname/ 2>&1";
	    my (@inrepo) = qx"repoman -t $version ls $repo_/source/$group/$pkgname/ 2>&1";
	    if ($inrepo[1] =~ 'No such file or') {
		print "Probably it is a new package, passing by...\n";
		return;
	    }
	    splice(@inrepo,0,1);
	    @inrepo = grep $_ ne "Changelog\n",@inrepo;
	    foreach $ir (@inrepo){
		unless(scalar grep(/\Q$ir\E/, @indarcs)){
		    $ec = apply "repoman -t $version del $repo/source/$group/$pkgname/$ir";
		}
	    }
	}
	
	if (@pkgfiles){
	    #      if( my $oldf = getoldfpm("$serverprefix/$repo/$repodir/",$pkgname) ){ 
	    #	apply "repoman -t $version del $repo/$repodir/$oldf";}}}
	    for my $pkgfile (@pkgfiles){
		$pkgfile =~ /^(.*)-.*?-.*?-.*?fpm\Z/;
		print "Something nasty with $pkgfile, is it a package file?" unless $1;
		if( my $oldf = getoldfpm("$serverprefix/$repo/$repodir/",$1) ){ 
		    $ev = apply "repoman -t $version del $repo/$repodir/$oldf";
		}
	    }
	} else {   # at least try to del old fpm
	    if( my $oldf = getoldfpm("$serverprefix/$repo/$repodir/",$pkgname) ){ 
		$ev = apply "repoman -t $version del $repo/$repodir/$oldf";
	    } else { print "Can't del package file!"; }
	}
    }
    die "Cleaning up FAILED!" if $ec||$ev;
}


sub Warning {
    print "What have you been hacking today?\n";
    unless ((my $what = qx"darcs what -s .") =~ /\QNo changes!\E/){ 
	print $what;
	exit unless (my $an = ask 'Have you checked your package? Everything is ok with it?') =~ /^y|^$/i;
    } else {print "Nothing!\n"}
}

Warning if $opts{W};
do { die if ChkFB } if $opts{H};
Record if $opts{R};
Cleanup if $opts{C};
Push if $opts{P};
Upload if $opts{U};
cL if $opts{L};

if ($opts{d}){ #delete source & fpm        doesnt ask it, -d is not default!
    for my $sourcefile (@sourcefiles){
	print "Deleting source file $sourcefile\n";
	unlink $sourcefile if $sourcefile;
    }
    for my $pkgfile (@pkgfiles){
      print "Deleting package $pkgfile\n";
      unlink $pkgfile if $pkgfile;
    }
}


__END__