X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;f=Topbloke.pm;h=4815b55d16ee06713eb3cb57d31ec333f7869529;hb=fbdf67103c969969b564342bb7aed61c8c7ed36b;hp=2ff8913708a2024feebc4a1c19b9467323c03769;hpb=54d8cc266fbccdab45a1c6a6d36a57f94849e7df;p=topbloke.git

diff --git a/Topbloke.pm b/Topbloke.pm
index 2ff8913..4815b55 100644
--- a/Topbloke.pm
+++ b/Topbloke.pm
@@ -3,6 +3,9 @@
 use strict;
 use warnings;
 
+use POSIX;
+use IO::File;
+
 package Topbloke;
 
 BEGIN {
@@ -11,40 +14,106 @@ BEGIN {
 
     $VERSION     = 1.00;
     @ISA         = qw(Exporter);
-    @EXPORT      = qw(parse_branch_spec current_tb_branch run_git_1line);
+    @EXPORT      = qw(parse_branch_spec current_tb_branch run_git_1line
+                      setup_config check_no_unwanted_metadata);
     %EXPORT_TAGS = ( );
     @EXPORT_OK   = qw();
 }
 
+sub debug ($) {
+    my ($msg) = @_;
+    print STDERR "DEBUG: $msg\n" or die $!;
+}
 
-sub run_git_1line {
-    my $xopts;
-    $xopts = ref $_[0] ? shift @_ : { };
-    open GIT, "-|", 'git', @_ or die $!;
-    my $l = <GIT>;
-    $?=0;
-    if ($xopts->{ExitStatus}) {
-	if (!close GIT) { 
-	    return ($?, undef);
+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 {
-	    chomp $l or die "@_ ?";
-	    return (0, $l);
+	    die ref($ref)." @_ ?";
 	}
     }
-    close GIT or die "git @_ failed ($?)\n";
-    chomp $l or die "@_ ?";
+    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 current_tb_branch () {
-    my ($estatus,$ref) = 
-	run_git_1line({ ExitStatus=>1 }, qw(symbolic-ref HEAD));
-    if ($estatus == 256) {
+    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'
+	    Kind => 'detached',
+	    Ref => $ref,
 	};
     }
-    die "$estatus ?" if $estatus;
     if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
 	return {
 	    Kind => $1,
@@ -121,4 +190,95 @@ sub parse_branch_spec ($) {
     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_estatus;
+	    my $current = run_git_1line(\$current_estatus,
+					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 wf_start ($) {
+    my ($path) = @_;
+    my $fh = new IO::File '>', "$path.tmp" or die "$path.tmp: $!";
+    $writing{$fh} = $path;
+    return [ $fh, $path ];
+}
+
+sub wf ($$) {
+    my ($wf, $data) = @_;
+    print $wf->[0] $data or die "$wf->[1]: $!";
+}
+
+sub wf_abort ($) {
+    my ($wf) = @_;
+    close $wf->[0];
+    unlink $wf->[1] or die "$wf->[1]: $!";
+}
+
+sub wf_done ($) {
+    my ($wf) = @_;
+    close $wf->[0] or die "$wf->[1]: $!";
+    rename $wf->[1].'.tmp', $wf->[1] or die "$wf->[1]: $!";
+}
+
+sub wf_contents ($$) {
+    my ($path,$contents) = @_;
+    my $wf = wf_start($path);
+    wf($wf, $contents);
+    wf_done($wf);
+}
+
 1;