# -*- perl -*-

package Topbloke;

use strict;
use warnings;

use POSIX;
use IO::File;
use IPC::Open2;
use File::Path qw(make_path remove_tree);
use File::Basename;

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

    $VERSION     = 1.00;
    @ISA         = qw(Exporter);
    @EXPORT      = qw(debug $tiprefs $baserefs
		      run_git run_git_1line run_git_check_nooutput
		      run_git_test_anyoutput git_get_object
		      git_config git_dir chdir_toplevel enable_reflog
		      current_branch parse_patch_spec parse_patch_name
		      setup_config check_no_unwanted_metadata
		      patch_matches_spec
		      foreach_patch
		      propsfile_add_prop depsfile_add_dep
		      wf_start wf wf_abort wf_done wf_contents
		      closeout);
    %EXPORT_TAGS = ( );
    @EXPORT_OK   = qw();
}

our $git_command = 'git';

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

#----- general interaction with git -----

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_command, @_ or die $!;
    if ($linecallr) {
	while (<GIT>) {
	    chomp or die "$git_command @_ gave $_ ?";
	    $linecallr->();
	}
	GIT->eof or die $!;
    }
    if (!close GIT) {
	die "$git_command @_ $!" if $!;
	die unless $?;
	die "$git_command @_ ($?)" 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_get_object ($) {
    my ($objname) = @_;
    our ($gro_pid, $gro_out, $gro_in);
    if (!$gro_pid) {
	$gro_pid = open2($gro_out, $gro_in, $git_command, qw(cat-file --batch))
	    or die $!;
    }
    #debug("git_get_object $objname");
    $SIG{'PIPE'} = 'IGN';
    print $gro_in $objname,"\n" or die $!;
    $gro_in->flush or die "$objname $!";
    $SIG{'PIPE'} = 'DFL';
    my $l = <$gro_out>;
    chomp $l or die "$objname $l ?";
    #debug("git_get_object $objname => $l");
    if ($l =~ m/ missing$/) {
	return 'missing';
    } elsif (my ($type,$bytes) = $l =~ m/^\S+ (\w+) (\d+)$/) {
	my $data = '';
	if ($bytes) {
	    (read $gro_out, $data, $bytes) == $bytes or die "$objname $!";
	}
	my $nl;
	(read $gro_out, $nl, 1) == 1 or die "$objname $!";
	$nl eq "\n" or die "$objname ?";
	return ($type, $data);
    } else {
	die "$objname $l";
    }
}

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;
}

#----- specific interactions with git -----

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 enable_reflog ($) {
    my ($branchref) = @_;
    $branchref =~ m#^refs/# or die;
    my $logsdir = git_dir().'/logs/';
    my $dirname = $logsdir.dirname($branchref);
    make_path($dirname) or die "$dirname $!";
    open REFLOG, '>>', $logsdir.$branchref or die "$logsdir$branchref $!";
    close REFLOG 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 check_clean_tree ($) {
    run_git_check_nooutput("operation requires working tree to be clean",
			   qw(diff --name-only HEAD --));
    run_git_check_nooutput("operation cannot proceed with staged changes",
			   qw(diff --cached --name-only HEAD --));
}

#----- configuring a tree -----

sub setup_config () {
    my (@files) = (qw(msg deps included props pprops));
    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 $!;
    }
}

#----- branch and patch specs and parsed patch names -----

our $tiprefs = 'refs/topbloke-tips';
our $baserefs = 'refs/topbloke-bases';

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/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
	my $fullname = "$2\@$3/$4/$'";
	return {
	    Kind => $1,
	    Email => $2,
	    Domain => $3,
	    Date => $4,
	    Nick => $', #',
	    Ref => $ref,
	    DepSpec => $fullname,
	    Fullname => $fullname,
	};
    } elsif ($ref =~ m#^refs/heads/#) {
	return {
	    Kind => 'foreign',
	    Ref => $ref,
	    DepSpec => ".f $ref",
	};
    } else {
	return {
	    Kind => 'weird',
	    Ref => $ref,
	};
    }
}

sub parse_patch_name ($) {
    my ($patch) = @_;
    my ($eaddr, $date, $nick) = split /\//, $patch, 3;
    defined $nick && length $nick or die "$patch ?";
    my ($email, $domain) = $eaddr =~ m/^(.*)\@([^\@]+)$/
	or die "$patch eaddr ?";
    return {
	Email => $email,
	Domain => $domain,
	Date => $date,
	Nick => $nick,
	Kind => 'tip',
	DepSpec => $patch,
	Fullname => $patch,
	Ref => "refs/topbloke-tips/$patch",
    };
}

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 patch_matches_spec ($$) {
    my ($parsedname, $spec) = @_;
    foreach my $k (qw(Email Domain Nick)) {
	debug("patch_matches_spec  mismatch $k"), return 0
	    if defined $spec->{$k} &&
	       $parsedname->{$k} ne $spec->{$k};
    }
    debug("patch_matches_spec  mismatch DatePrefix"), return 0
	if defined $spec->{DatePrefix} &&
	   substr($parsedname->{Date}, 0, length $spec->{DatePrefix})
	       ne $spec->{DatePrefix};
    debug("patch_matches_spec  match"), return 1;
}

#----- reading topbloke metadata -----

sub foreach_patch ($$$$) {
    my ($spec, $deleted_ok, $want, $body) = @_;
    # runs $body->($patch, $parsedname, \%props, \%deps, \%pprops, \%included)
    #                                   $want->[0]   1        2         3
    # where $deps->{$fullname} etc. are 1 for true or nonexistent for false
    #  and if $want->[$item] is not true, the corresponding item may be undef
    # and $parsedname is only valid if $spec is not undef
    #  (say $spec { }  if you want the name parsed but no restrictions)
    my @want = @$want;
    $want[0] ||= !$deleted_ok;
    run_git(sub {
	debug("foreach_patch considering $_");
	m/ / or die "$_ ?";
	my $objname = $`;
	my @out;
	my $patch = substr($',19); #');
	my $wantix = 0;
	foreach my $file (qw(props deps pprops included)) {

	    if ($file eq 'deps') {
		# do this check after checking for deleted patches,
		# so we don't parse deleted patches' names
		# right, check the spec next
		if ($spec) {
		    my $have = parse_patch_name($patch);
		    debug("foreach_patch  mismatch"), return
			unless patch_matches_spec($have, $spec);
		    unshift @out, $have;
		} else {
		    unshift @out, undef;
		}
	    }

	    if (!$want[$wantix++]) {
		push @out, undef;
		next;
	    }

	    my ($got, $data) = git_get_object("$objname:.topbloke/$file");
	    die "$patch $file ?" unless defined $data;
	    my %data;
	    if ($file !~ m/props/) {
		$data{$_}=1 foreach split /\n/, $data;
	    } elseif {
		foreach (split /\n/, $data) {
		    m/ / or m/$/;
		    $data{$`} = $'; #';
		}
	    }

	    if ($file eq 'props') {
		debug("foreach_patch  Deleted"), return
		    if !$deleted_ok && $data{Deleted};
	    }

	    push @out, \%data;
	}
	debug("foreach_patch  YES ".(join '', map { 0+defined } @out)), return
	$body->($patch, @out);
	    },
	    qw(for-each-ref --format), '%(objectname) %(refname)',
	        qw(refs/topbloke-tips));
}

#----- updating topbloke metadata -----

sub propsfile_set_prop ($$$) {
    # set $value to undef to delete; returns old value
    my ($propsfile, $prop, $value) = @_;
    my $wf = wf_start(".topbloke/$propsfile");
    my $oldvalue;
    open FI, '<', ".topbloke/$propsfile" or die $!;
    while (<FI>) {
	chomp or die;
	m/ / or m/$/;
	if ($` eq $prop) {
	    die "prop $prop repeated in $propsfile ?!" if defined $oldvalue;
	    $oldvalue = $'; #';
	} else {
	    wf($wf, "$_\n");
	}
    }
    FI->error and die $!;
    close FI or die $!;
    wf($wf, "$prop $value\n") if defined $value;
    wf_done($wf);
    return $oldvalue;
}

sub depssfile_add_dep ($$) {
    my ($depsfile, $depspec) = @_;
    my $wf = wf_start(".topbloke/$depsfile");
    open FI, '<', ".topbloke/$depsfile" or die $!;
    while (<FI>) {
	chomp or die;
	die "dep $depspec already set in $depsfile ?!" if $_ eq $depspec;
	wf($wf, "$_\n");
    }
    FI->error and die $!;
    close FI or die $!;
    wf($wf, "$depspec\n");
    wf_done($wf);
}

#----- general utilities -----

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);
}

sub closeout () {
    STDOUT->error and die $!;
    close STDOUT or die $!;
}

1;
