# -*- perl -*-

use strict;
use warnings;

use POSIX;
use IO::File;

package Topbloke;

BEGIN {
    use Exporter   ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

    $VERSION     = 1.00;
    @ISA         = qw(Exporter);
    @EXPORT      = qw(debug
		      run_git run_git_1line run_git_check_nooutput
		      run_git_test_anyoutput
		      git_config git_dir chdir_toplevel
		      current_branch parse_patch_spec
		      setup_config check_no_unwanted_metadata
		      flagsfile_add_flag
		      wf_start wf wf_abort wf_done wf_contents);
    %EXPORT_TAGS = ( );
    @EXPORT_OK   = qw();
}

sub debug ($) {
    my ($msg) = @_;
    print STDERR "DEBUG: $msg\n" or die $!;
}

sub run_git {
    # takes optional prefix arguments:
    #    coderef    hook to call for each line read,
    #                with $_ containing chomped line; if not supplied,
    #                output is not read
    #    scalarref  place to store exit status; if not supplied,
    #                nonzero exit status is fatal
    my ($estatusr,$linecallr);
    while (ref $_[0]) {
	my $ref = shift @_;
	if (ref $ref eq 'SCALAR') {
	    $estatusr = $ref;
	} elsif (ref $ref eq 'CODE') {
	    $linecallr = $ref;
	} else {
	    die ref($ref)." @_ ?";
	}
    }
    open GIT, "-|", 'git', @_ or die $!;
    if ($linecallr) {
	while (<GIT>) {
	    chomp or die "$_ ?";
	    $linecallr->();
	}
	GIT->eof or die $!;
    }
    if (!close GIT) {
	die "git @_ $!" if $!;
	die unless $?;
	die "git @_ ($?)" unless $estatusr;
	$$estatusr = $?;
    } else {
	$$estatusr = 0 if $estatusr;
    }
}

sub run_git_1line {
    my $l;
    run_git(sub { $l = $_; }, @_);
    die "git @_ ?" unless defined $l;
    return $l;
}

sub run_git_check_nooutput {
    my ($what) = shift @_;
    run_git(sub { die "$what $_\n"; }, @_);
}

sub run_git_test_anyoutput {
    my $any = 0;
    run_git(sub { $any=1; }, @_);
    return $any;
}

sub git_config ($$) {
    my ($cfgvar, $default) = @_;
    my ($l, $estatus);
    run_git(\$estatus, sub { 
	die if defined $l; 
	$l = $_; },
	    qw(config), $cfgvar);
    if (defined $l) {
	die "$cfgvar ($estatus)" if $estatus;
	return $l;
    } else {
	die "$cfgvar ($estatus)" unless $estatus==0 || $estatus==256;
	return $default;
    }
}

sub git_dir () {
    our $git_dir;
    if (!defined $git_dir) {
	$git_dir = run_git_1line(qw(rev-parse --git-dir));
    }
    return $git_dir;
}

sub chdir_toplevel () {
    my $toplevel;
    run_git(sub { $toplevel = $_; }, 
	    qw(rev-parse --show-toplevel));
    die "not in working tree?\n" unless defined $toplevel;
    chdir $toplevel or die "chdir toplevel $toplevel: $!\n";
}

sub current_branch () {
    open R, git_dir().'/HEAD' or die "open HEAD $!";
    my $ref = <R>;  defined $ref or die $!;
    close R;
    chomp $ref or die;
    if ($ref !~ s#^ref: ##) {
	return {
	    Kind => 'detached',
	    Ref => $ref,
	};
    }
    if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
	return {
	    Kind => $1,
	    Email => $2,
	    Domain => $3,
	    Date => $4,
	    Nick => $', #',
	    Ref => $ref,
	    DepSpec => "$2\@$3/$4/$'",
	};
    } elsif ($ref =~ m#^refs/heads/#) {
	return {
	    Kind => 'foreign',
	    Ref => $ref,
	    DepSpec => "/$ref",
	};
    } else {
	return {
	    Kind => 'weird',
	    Ref => $ref,
	};
    }
}

sub parse_patch_spec ($) {
    my ($orig) = @_;
    local $_ = $orig;
    my $spec = { }; # Email Domain DatePrefix DateNear Nick
    my $set = sub {
	my ($key,$val,$whats) = @_;
	die "multiple $whats in patch spec\n" if exists $spec->{$key};
	$spec->{$key} = $val;
    };
    my $rel_levels;
    for (;;) {
	if (s#([^/\@]*)\@([^/\@]*)/##) {
	    $set->('Email', $1, "email local parts") if length $1;
	    $set->('Domain', $2, "email domains") if length $1;
	} elsif (s#([^/]*\~[^/]*)/##) {
	    my $dspec = $1;
	    $dspec =~ y/~/ /;
	    open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
	    my $l = <DATE>;
	    close DATE or die "date parsing failed\n";
	    chomp $l or die;
	    $set->('DateNear', $l, 'nearby dates');
	} elsif (s#^([0-9][^/]*)/##) {
	    my $dspec = $1;
	    $dspec =~ 
      m/^\d{4}(?:-\d\d(?:-\d\d(?:T(?:\d\d(?:\d\d(?:\d\d(?:Z)?)?)?)?)?)?)?$/
		or die "bad date prefix \`$dspec'\n";
	    $set->('DatePrefix', $dspec, 'date prefixes');
	} elsif (s#^\./##) {
	    $rel_levels ||= 1;
	} elsif (s#^\.\./##) {
	    $rel_levels ||= 1;
	    $rel_levels++;
	} else {
	    last;
	}
    }
    if (defined $rel_levels) {
	my $branch = current_branch();
	if (!defined $branch->{Nick}) {
	    die "relative patch spec \`$orig',".
		" but current branch not a topbloke patch\n";
	}
	my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
	@l >= $rel_levels or
	    die "relative patch spec \`$orig' has too many ../s\n";
	$_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
    } elsif (length) {
	$spec->{Nick} = $_;
    }
    return $spec;
}

sub setup_config () {
    my (@files) = (qw(msg deps included flags pflags));
    my $version = 1;
    foreach my $iteration (qw(0 1)) {
	foreach my $file (@files) {
	    my $cfgname = "merge.topbloke-$file";
	    my ($current, $current_estatus);
	    run_git(\$current_estatus,
		    sub { $current = $_; },
		    qw(config), "$cfgname.driver");
	    $current = "## failed $current_estatus" if $current_estatus;
	    next if $current =~ m/^topbloke-merge-driver --v$version /o;
	    die "$file $current ?" if $iteration;
	    debug("setting merge driver $file");
	    run_git(qw(config), "$cfgname.name",
		    "topbloke merge driver for $file");
	    run_git(qw(config), "$cfgname.driver",
		    "topbloke-merge-driver --v$version".
		    " $file %O %A %B %L");
	}
	my ($newattrs, $attrsfile);
	foreach my $file (@files) {
	    my $path = ".topbloke/$file";
	    my $current = run_git_1line(qw(check-attr merge), $path);
	    $current =~ s#^\Q$path\E: merge: ## or die "$file $current ?";
	    my $want = "topbloke-$file";
	    next if $current eq $want;
	    die "$file $current ?" unless $current eq 'unspecified';
	    die "$file $current ?" if $iteration;
	    if (!$newattrs) {
		$attrsfile = git_dir()."/info/attributes";
		$newattrs = new IO::File "$attrsfile.tmp", 'w'
		    or die "$attrsfile.tmp: $!";
		if (!open OA, '<', "$attrsfile") {
		    die "$attrsfile $!" unless $!==&ENOENT;
		} else {
		    while (<OA>) {
			print $newattrs $_ or die $!;
			print "\n" or die $! unless chomp;
		    }
		    die $! if OA->error;
		    die $! unless close OA;
		}
	    }
	    print $newattrs "$path\tmerge=$want\n" or die $!;
	}
	last if !$newattrs;
	close $newattrs or die $!;
	rename "$attrsfile.tmp", "$attrsfile" or die $!;
    }
}

sub check_no_unwanted_metadata ($) {
    # for checking foreign branches aren't contaminated
    my ($gitbranch) = @_;
    run_git_check_nooutput('foreign unexpectedly contains',
			   qw(ls-tree --name-only),
			   "$gitbranch:",
			   qw(.topbloke));
}

sub flagsfile_add_flag ($$) {
    # works on "deps" too
    my ($flagsfile, $flag) = @_;
    my $wf = wf_start(".topbloke/$flagsfile");
    open FI, '<', ".topbloke/$flagsfile" or die $!;
    while (<FI>) {
	chomp or die;
	die "flag $flag already set in $flagsfile ?!" if $_ eq $flag;
	wf($wf, "$_\n");
    }
    FI->error and die $!;
    close FI or die $!;
    wf($wf, "$flag\n");
    wf_done($wf);
}

sub wf_start ($) {
    my ($path) = @_;
    my $fh = new IO::File "$path.tmp", '>' or die "create $path.tmp: $!\n";
    return [ $fh, $path ];
}

sub wf ($$) {
    my ($wf, $data) = @_;
    my ($fh, $path) = @$wf;
    print $fh $data or die "write $path.tmp: $!\n";
}

sub wf_abort ($) {
    my ($wf) = @_;
    my ($fh, $path) = @$wf;
    close $fh;
    unlink "$path.tmp" or die "remove $path.tmp: $!\n";
}

sub wf_done ($) {
    my ($wf) = @_;
    my ($fh, $path) = @$wf;
    close $fh or die "finish writing $path.tmp: $!\n";
    rename "$path.tmp", $path or die "install new $path: $!\n";
}

sub wf_contents ($$) {
    my ($path,$contents) = @_;
    my $wf = wf_start($path);
    wf($wf, $contents);
    wf_done($wf);
}

1;
