11 use File::Path qw(make_path remove_tree);
18 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
22 @EXPORT = qw(debug $tiprefs $baserefs %known_metadata
23 run_git run_git_1line run_git_check_nooutput
24 run_git_test_anyoutput git_get_object
25 git_config git_dir chdir_toplevel enable_reflog
26 check_no_metadata foreach_unknown_metadata
29 current_branch parse_patch_name parse_patch_spec
32 metafile_process depsfile_add_dep
33 wf_start wf wf_abort wf_done wf_contents
39 our $git_command = 'git';
45 print STDERR "DEBUG: $msg\n" or die $!;
48 #----- general interaction with git -----
51 # takes optional prefix arguments:
52 # coderef hook to call for each line read,
53 # with $_ containing chomped line; if not supplied,
55 # scalarref place to store exit status; if not supplied,
56 # nonzero exit status is fatal
57 my ($estatusr,$linecallr);
60 if (ref $ref eq 'SCALAR') {
62 } elsif (ref $ref eq 'CODE') {
65 die ref($ref)." @_ ?";
68 open GIT, "-|", $git_command, @_ or die $!;
71 chomp or die "$git_command @_ gave $_ ?";
77 die "$git_command @_ $!" if $!;
79 die "$git_command @_ ($?)" unless $estatusr;
82 $$estatusr = 0 if $estatusr;
88 run_git(sub { $l = $_; }, @_);
89 die "git @_ ?" unless defined $l;
93 sub run_git_check_nooutput {
94 my ($what) = shift @_;
95 run_git(sub { die "$what $_\n"; }, @_);
98 sub run_git_test_anyoutput {
100 run_git(sub { $any=1; }, @_);
104 sub git_get_object ($) {
106 our ($gro_pid, $gro_out, $gro_in);
108 $gro_pid = open2($gro_out, $gro_in, $git_command, qw(cat-file --batch))
111 #debug("git_get_object $objname");
112 $SIG{'PIPE'} = 'IGN';
113 print $gro_in $objname,"\n" or die $!;
114 $gro_in->flush or die "$objname $!";
115 $SIG{'PIPE'} = 'DFL';
117 chomp $l or die "$objname $l ?";
118 #debug("git_get_object $objname => $l");
119 if ($l =~ m/ missing$/) {
121 } elsif (my ($type,$bytes) = $l =~ m/^\S+ (\w+) (\d+)$/) {
124 (read $gro_out, $data, $bytes) == $bytes or die "$objname $!";
127 (read $gro_out, $nl, 1) == 1 or die "$objname $!";
128 $nl eq "\n" or die "$objname ?";
129 return ($type, $data);
135 sub git_config ($$) {
136 my ($cfgvar, $default) = @_;
138 run_git(\$estatus, sub {
141 qw(config), $cfgvar);
143 die "$cfgvar ($estatus)" if $estatus;
146 die "$cfgvar ($estatus)" unless $estatus==0 || $estatus==256;
153 if (!defined $git_dir) {
154 $git_dir = run_git_1line(qw(rev-parse --git-dir));
159 #----- specific interactions with git -----
161 sub chdir_toplevel () {
163 run_git(sub { $toplevel = $_; },
164 qw(rev-parse --show-toplevel));
165 die "not in working tree?\n" unless defined $toplevel;
166 chdir $toplevel or die "chdir toplevel $toplevel: $!\n";
169 sub enable_reflog ($) {
170 my ($branchref) = @_;
171 $branchref =~ m#^refs/# or die;
172 my $logsdir = git_dir().'/logs/';
173 my $dirname = $logsdir.dirname($branchref);
174 make_path($dirname) or die "$dirname $!";
175 open REFLOG, '>>', $logsdir.$branchref or die "$logsdir$branchref $!";
176 close REFLOG or die $!;
179 sub check_no_metadata ($) {
180 # for checking foreign branches aren't contaminated
181 my ($gitbranch) = @_;
182 run_git_check_nooutput('foreign unexpectedly contains',
183 qw(ls-tree --name-only),
188 sub foreach_unknown_metadata ($$) {
189 my ($ref, $code) = @_;
191 # Executes $code for each tolerable unknown metadata found, with
192 # $_ being the (leaf) name of the metadata file
194 die unless s#^\.topbloke/##;
195 next if $known_metadata{$_};
196 m/-$/ or die "found unsupported metadata in $ref; you must upgrade\n";
199 qw(ls-tree --name-only -r HEAD: .topbloke));
202 sub check_clean_tree ($) {
203 run_git_check_nooutput("operation requires working tree to be clean",
204 qw(diff --name-only HEAD --));
205 run_git_check_nooutput("operation cannot proceed with staged changes",
206 qw(diff --cached --name-only HEAD --));
209 $known_metadata{$_}=1 foreach qw(msg patch base deps deleted
212 #----- configuring a tree -----
214 sub setup_config () {
215 my (@files) = (qw(lwildcard- msg patch base deps deleted
216 +iwildcard- +included +ends));
224 foreach my $iteration (qw(0 1)) {
225 foreach my $file (@files) {
226 my $cfgname = "merge.topbloke-".$drvname->($file);
227 my ($current, $current_estatus);
228 run_git(\$current_estatus,
229 sub { $current = $_; },
230 qw(config), "$cfgname.driver");
231 $current = "## failed $current_estatus" if $current_estatus;
232 next if $current =~ m/^topbloke-merge-driver --v$version /o;
233 die "$file $current ?" if $iteration;
234 debug("setting merge driver $file");
235 run_git(qw(config), "$cfgname.name",
236 "topbloke merge driver for $file");
237 run_git(qw(config), "$cfgname.driver",
238 "topbloke-merge-driver --v$version".
239 " $file %O %A %B %L");
241 my ($newattrsprefix, $newattrs, $attrsfile);
245 foreach my $file (@files) {
246 my ($pat,$check) = ($file, $file);
247 if ($file =~ m/wildcard/) {
248 $pat = ($file =~ m/^\+/ ? '+' : '[^+]').'*';
249 $check =~ s/\w.*/xxxunknown/ or die;
251 $pat = ".topbloke/$pat";
252 $check = ".topbloke/$check";
253 my $want = "topbloke-".$drvname->($file);
254 $attrs .= "$pat\tmerge=$want\n";
255 my $current = run_git_1line(qw(check-attr merge), $check);
256 $current =~ s#^\Q$check\E: merge: ## or die "$file $current ?";
257 next if $current eq $want;
258 die "$file $current ?" unless
259 $current eq 'unspecified' ||
260 $current =~ m/^topbloke-\wwildcard$/;
261 push @needupdate, "$file=$current";
264 $attrsfile = git_dir()."/info/attributes";
265 my $newattrsf = new IO::File "$attrsfile.tmp", 'w'
266 or die "$attrsfile.tmp: $!";
267 die "@needupdate ?" if $iteration;
268 if (!open OA, '<', "$attrsfile") {
269 die "$attrsfile $!" unless $!==ENOENT;
272 next if m#^\.topbloke/#;
273 print $newattrsf $_ or die $!;
274 print $newattrsf "\n" or die $! unless chomp;
277 die $! unless close OA;
279 print $newattrsf $attrs or die $!;
280 close $newattrsf or die $!;
281 rename "$attrsfile.tmp", "$attrsfile" or die $!;
286 #----- branch and patch specs and parsed patch names -----
288 our $tiprefs = 'refs/topbloke-tips';
289 our $baserefs = 'refs/topbloke-bases';
291 sub current_branch () {
292 open R, git_dir().'/HEAD' or die "open HEAD $!";
293 my $ref = <R>; defined $ref or die $!;
296 if ($ref !~ s#^ref: ##) {
302 if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
303 my $fullname = "$2\@$3/$4/$'";
311 DepSpec => $fullname,
312 Fullname => $fullname,
315 } elsif ($ref =~ m#^refs/heads/#) {
329 sub parse_patch_name ($) {
331 my ($eaddr, $date, $nick) = split /\//, $patch, 3;
332 defined $nick && length $nick or die "$patch ?";
333 my ($email, $domain) = $eaddr =~ m/^(.*)\@([^\@]+)$/
334 or die "$patch eaddr ?";
343 Ref => "refs/topbloke-tips/$patch",
347 sub parse_patch_spec ($) {
350 warn 'FORMAT has new spec syntax nyi';
351 my $spec = { }; # Email Domain DatePrefix DateNear Nick
353 my ($key,$val,$whats) = @_;
354 die "multiple $whats in patch spec\n" if exists $spec->{$key};
355 $spec->{$key} = $val;
359 if (s#([^/\@]*)\@([^/\@]*)/##) {
360 $set->('Email', $1, "email local parts") if length $1;
361 $set->('Domain', $2, "email domains") if length $1;
362 } elsif (s#([^/]*\~[^/]*)/##) {
365 open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
367 close DATE or die "date parsing failed\n";
369 $set->('DateNear', $l, 'nearby dates');
370 } elsif (s#^([0-9][^/]*)/##) {
373 m/^\d{4}(?:-\d\d(?:-\d\d(?:T(?:\d\d(?:\d\d(?:\d\d(?:Z)?)?)?)?)?)?)?$/
374 or die "bad date prefix \`$dspec'\n";
375 $set->('DatePrefix', $dspec, 'date prefixes');
378 } elsif (s#^\.\./##) {
385 if (defined $rel_levels) {
386 my $branch = current_branch();
387 if (!defined $branch->{Nick}) {
388 die "relative patch spec \`$orig',".
389 " but current branch not a topbloke patch\n";
391 my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
393 die "relative patch spec \`$orig' has too many ../s\n";
394 $_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
401 sub patch_matches_spec ($$) {
402 my ($parsedname, $spec) = @_;
403 foreach my $k (qw(Email Domain Nick)) {
404 debug("patch_matches_spec mismatch $k"), return 0
405 if defined $spec->{$k} &&
406 $parsedname->{$k} ne $spec->{$k};
408 debug("patch_matches_spec mismatch DatePrefix"), return 0
409 if defined $spec->{DatePrefix} &&
410 substr($parsedname->{Date}, 0, length $spec->{DatePrefix})
411 ne $spec->{DatePrefix};
412 debug("patch_matches_spec match"), return 1;
415 #----- reading topbloke metadata -----
417 sub foreach_patch ($$$$) {
418 my ($spec, $deleted_ok, $want, $body) = @_;
419 print STDERR Dumper(\@_);
420 # runs $body->($patch, $parsedname, \%meta)
421 # where $meta{<metadata filename>} is, for <metadata filename> in @$want:
422 # undefined if metadata file doesn't exist
423 # defined with contents of file
424 # and $parsedname is only valid if $spec is not undef
425 # (say $spec { } if you want the name parsed but no restrictions)
426 # entries in want may also be "<metadata filename>_"
427 # which means "strip trailing newlines" (result key in %meta is the same)
428 # <metadata filename> may instead be "B_<metadata filename>"
429 # which means to look in the corresponding base branch
433 @want = ($thing, grep { $_ ne $thing } @want);
435 $atfront->(' patch');
436 $atfront->('deleted') unless $deleted_ok;
438 debug("foreach_patch considering $_");
443 my $patch = substr($',19); #');
445 print STDERR Dumper(\@want);
446 foreach my $wantent (@want) {
448 my $stripnl = ($file =~ s/_$//);
449 my $inbase = ($file =~ s/^B_//);
451 if ($file eq ' patch') {
452 print STDERR "has spc patch\n";
454 print STDERR "hasspec\n";
455 $parsedname = parse_patch_name($patch);
456 if (!patch_matches_spec($parsedname, $spec)) {
457 debug("foreach_patch mismatch");
464 my $objkey = (!$inbase ? "$objname" :
465 "refs/topbloke-bases/$patch").":.topbloke/$file";
466 my ($got, $data) = git_get_object($objkey);
467 if ($got eq 'missing') {
468 $meta{$file} = undef;
469 } elsif ($got eq 'blob') {
470 $meta{$file} = $data;
471 if ($file eq 'deleted' && !$deleted_ok) {
472 debug("foreach_patch Deleted");
476 warn "patch $patch object $objkey has unexpected type $got!\n";
480 debug("foreach_patch YES $patch");
481 $body->($patch, $parsedname, \%meta);
483 qw(for-each-ref --format), '%(objectname) %(refname)',
484 qw(refs/topbloke-tips));
487 #----- updating topbloke metadata -----
489 sub metafile_process ($$$$$) {
490 my ($metafile, $startcode, $linecode, $endcode, $enoentcode) = @_;
491 # runs $startcode->($outwf) at start
492 # runs $linecode->($outwf) for each old line, with $_ the chomped line
493 # may modify $_, which will be written to $outf
494 # at end runs $endcode->($outwf);
495 # runs $enoentcode->($outwf) instead of ever calling $linecode
496 # if the existing file does not exist;
497 # if it's false dies instead
498 # any of these may return false, in which case we quit immediately
499 # any of these except enoentcode may be undef to mean "noop"
500 # if they all return true, we install the new file
501 my $wf = wf_start(".topbloke/$metafile");
503 return 1 unless $_->[0];
504 return 1 if $_->[0]($wf);
509 return unless $call->($startcode);
510 if (!open FI, '<', ".topbloke/$metafile") {
511 die "$metafile $!" unless $!==ENOENT;
512 die "$metafile $!" unless $enoentcode;
513 return unless $call->($enoentcode);
517 return unless $call->($linecode);
520 FI->error and die $!;
523 return unless $call->($endcode);
528 sub depsfile_add_dep ($$) {
529 my ($depsfile, $depspec) = @_;
530 metafile_process($depsfile, undef, sub {
531 die "dep $depspec already set in $depsfile ?!" if $_ eq $depspec;
533 wf($_->[0], "$depspec\n");
537 #----- general utilities -----
541 my $fh = new IO::File "$path.tmp", '>' or die "create $path.tmp: $!\n";
542 return [ $fh, $path ];
546 my ($wf, $data) = @_;
547 my ($fh, $path) = @$wf;
548 print $fh $data or die "write $path.tmp: $!\n";
553 my ($fh, $path) = @$wf;
555 unlink "$path.tmp" or die "remove $path.tmp: $!\n";
560 my ($fh, $path) = @$wf;
561 close $fh or die "finish writing $path.tmp: $!\n";
562 rename "$path.tmp", $path or die "install new $path: $!\n";
565 sub wf_contents ($$) {
566 my ($path,$contents) = @_;
567 my $wf = wf_start($path);
573 STDOUT->error and die $!;
574 close STDOUT or die $!;