X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;f=Topbloke.pm;h=d33d87f7dc77f8cbddb5f1ed23c8dc19cb749cde;hb=f188259a4c10646773fe0bbde14aadd419f341c9;hp=f1c06154fc41dd1237249fc51c5eee107b68daba;hpb=98c96c9695b93d1ed7cf2ea81d1851364faad0ba;p=topbloke.git

diff --git a/Topbloke.pm b/Topbloke.pm
index f1c0615..d33d87f 100644
--- a/Topbloke.pm
+++ b/Topbloke.pm
@@ -14,8 +14,14 @@ BEGIN {
 
     $VERSION     = 1.00;
     @ISA         = qw(Exporter);
-    @EXPORT      = qw(parse_branch_spec current_tb_branch run_git_1line
-                      setup_config check_no_unwanted_metadata);
+    @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();
 }
@@ -103,7 +109,15 @@ sub git_dir () {
     return $git_dir;
 }
 
-sub current_tb_branch () {
+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;
@@ -138,13 +152,13 @@ sub current_tb_branch () {
     }
 }
 
-sub parse_branch_spec ($) {
+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 branch spec\n" if exists $spec->{$key};
+	die "multiple $whats in patch spec\n" if exists $spec->{$key};
 	$spec->{$key} = $val;
     };
     my $rel_levels;
@@ -176,14 +190,14 @@ sub parse_branch_spec ($) {
 	}
     }
     if (defined $rel_levels) {
-	my $branch = current_tb_branch();
+	my $branch = current_branch();
 	if (!defined $branch->{Nick}) {
-	    die "relative branch spec \`$orig',".
-		" but current branch not a topbloke branch\n";
+	    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 branch spec \`$orig' has too many ../s\n";
+	    die "relative patch spec \`$orig' has too many ../s\n";
 	$_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
     }
     $spec->{Nick} = $_;
@@ -196,9 +210,10 @@ sub setup_config () {
     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");
+	    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;
@@ -250,4 +265,53 @@ sub check_no_unwanted_metadata ($) {
 			   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;