+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, \%meta)
+ # where $meta{<metadata filename>} is, for <metadata filename> in @$want:
+ # undefined if metadata file doesn't exist
+ # defined with contents of file
+ # and $parsedname is only valid if $spec is not undef
+ # (say $spec { } if you want the name parsed but no restrictions)
+ # entries in want may also be "<metadata filename>_"
+ # which means "strip trailing newlines" (result key in %meta is the same)
+ # <metadata filename> may instead be "B_<metadata filename>"
+ # which means to look in the corresponding base branch
+ my @want = @$want;
+ my $atfront = sub {
+ my ($thing) = @_;
+ @want = ($thing, grep { $_ ne $thing } @want);
+ };
+ $atfront->(' patch');
+ $atfront->('deleted') unless $deleted_ok;
+ run_git(sub {
+ debug("foreach_patch considering $_");
+ m/ / or die "$_ ?";
+ my $objname = $`;
+ my %meta;
+ my $parsedname;
+ my $patch = substr($',19); #');
+ my $wantix = 0;
+ foreach my $wantent (@want) {
+ my $file = $wantent;
+ my $stripnl = ($file =~ s/_$//);
+ my $key = $file;
+ my $inbase = ($file =~ s/^B_//);
+
+ if ($file eq ' patch') {
+ if ($spec) {
+ $parsedname = parse_patch_name($patch);
+ if (!patch_matches_spec($parsedname, $spec)) {
+ debug("foreach_patch mismatch");
+ return;
+ }
+ }
+ next;
+ }
+
+ my $objkey = (!$inbase ? "$objname" :
+ "$baserefs/$patch").":.topbloke/$file";
+ my ($got, $data) = git_get_object($objkey);
+ if ($got eq 'missing') {
+ $meta{$key} = undef;
+ } elsif ($got eq 'blob') {
+ $meta{$key} = $data;
+ if ($file eq 'deleted' && !$deleted_ok) {
+ debug("foreach_patch Deleted");
+ return;
+ }
+ } else {
+ warn "patch $patch object $objkey has unexpected type $got!\n";
+ return;
+ }
+ }
+ debug("foreach_patch YES $patch");
+ $body->($patch, $parsedname, \%meta);
+ },
+ qw(for-each-ref --format), '%(objectname) %(refname)',
+ qw(refs/topbloke-tips));
+}
+
+#----- updating topbloke metadata -----
+
+sub metafile_process ($$$$$) {
+ my ($metafile, $startcode, $linecode, $endcode, $enoentcode) = @_;
+ # runs $startcode->($outwf) at start
+ # runs $linecode->($outwf) for each old line, with $_ the chomped line
+ # may modify $_, which will be written to $outf
+ # at end runs $endcode->($outwf);
+ # runs $enoentcode->($outwf) instead of ever calling $linecode
+ # if the existing file does not exist;
+ # if it's false dies instead
+ # any of these may return false, in which case we quit immediately
+ # any of these except enoentcode may be undef to mean "noop"
+ # if they all return true, we install the new file
+ my $wf = wf_start(".topbloke/$metafile");
+ my $call = sub {
+ return 1 unless $_->[0];
+ return 1 if $_->[0]($wf);
+ wf_abort($wf);
+ close FI;
+ return 0;
+ };
+ return unless $call->($startcode);
+ if (!open FI, '<', ".topbloke/$metafile") {
+ die "$metafile $!" unless $!==ENOENT;
+ die "$metafile $!" unless $enoentcode;
+ return unless $call->($enoentcode);
+ } else {
+ while (<FI>) {
+ chomp or die;
+ return unless $call->($linecode);
+ wf($wf, "$_\n");
+ }
+ FI->error and die $!;
+ close FI or die $!;
+ }
+ return unless $call->($endcode);
+ wf_done($wf);
+}
+
+
+sub depsfile_add_dep ($$) {
+ my ($depsfile, $depspec) = @_;
+ metafile_process($depsfile, undef, sub {
+ die "dep $depspec already set in $depsfile ?!" if $_ eq $depspec;
+ }, sub {
+ wf($_->[0], "$depspec\n");
+ }, undef);
+}
+
+#----- 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 $!;
+}
+