chiark / gitweb /
wip tb-list
[topbloke.git] / Topbloke.pm
1 # -*- perl -*-
2
3 use strict;
4 use warnings;
5
6 use POSIX;
7 use IO::File;
8 use IPC::Open2;
9
10 package Topbloke;
11
12 BEGIN {
13     use Exporter   ();
14     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
15
16     $VERSION     = 1.00;
17     @ISA         = qw(Exporter);
18     @EXPORT      = qw(debug
19                       run_git run_git_1line run_git_check_nooutput
20                       run_git_test_anyoutput
21                       git_config git_dir chdir_toplevel
22                       current_branch parse_patch_spec
23                       setup_config check_no_unwanted_metadata
24                       foreach_patch
25                       flagsfile_add_flag
26                       wf_start wf wf_abort wf_done wf_contents);
27     %EXPORT_TAGS = ( );
28     @EXPORT_OK   = qw();
29 }
30
31 our $git_command = 'git';
32
33 sub debug ($) {
34     my ($msg) = @_;
35     print STDERR "DEBUG: $msg\n" or die $!;
36 }
37
38 sub run_git {
39     # takes optional prefix arguments:
40     #    coderef    hook to call for each line read,
41     #                with $_ containing chomped line; if not supplied,
42     #                output is not read
43     #    scalarref  place to store exit status; if not supplied,
44     #                nonzero exit status is fatal
45     my ($estatusr,$linecallr);
46     while (ref $_[0]) {
47         my $ref = shift @_;
48         if (ref $ref eq 'SCALAR') {
49             $estatusr = $ref;
50         } elsif (ref $ref eq 'CODE') {
51             $linecallr = $ref;
52         } else {
53             die ref($ref)." @_ ?";
54         }
55     }
56     open GIT, "-|", $git_command, @_ or die $!;
57     if ($linecallr) {
58         while (<GIT>) {
59             chomp or die "$git_command @_ gave $_ ?";
60             $linecallr->();
61         }
62         GIT->eof or die $!;
63     }
64     if (!close GIT) {
65         die "$git_command @_ $!" if $!;
66         die unless $?;
67         die "$git_command @_ ($?)" unless $estatusr;
68         $$estatusr = $?;
69     } else {
70         $$estatusr = 0 if $estatusr;
71     }
72 }
73
74 sub run_git_1line {
75     my $l;
76     run_git(sub { $l = $_; }, @_);
77     die "git @_ ?" unless defined $l;
78     return $l;
79 }
80
81 sub run_git_check_nooutput {
82     my ($what) = shift @_;
83     run_git(sub { die "$what $_\n"; }, @_);
84 }
85
86 sub run_git_test_anyoutput {
87     my $any = 0;
88     run_git(sub { $any=1; }, @_);
89     return $any;
90 }
91
92 sub git_get_object ($) {
93     my ($objname) = @_;
94     our ($gro_pid, $gro_out, $gro_in);
95     if (!$gro_pid) {
96         $gro_pid = IPC::Open2::open2($gro_out, $gro_in,
97                                      $git_command, qw(cat-file --batch))
98             or die $!;
99     }
100     $SIG{'PIPE'} = 'IGN';
101     print $gro_in $objname,"\n" or die $!;
102     $gro_in->flush or die "$objname $!";
103     $SIG{'PIPE'} = 'DFL';
104     my $l = <$gro_out>;
105     chomp $l or die "$objname $l ?";
106     if ($l =~ m/ missing$/) {
107         return 'missing';
108     } elsif (my ($type,$bytes) = $l =~ m/^\S+ (\w+) (\d+)$/) {
109         my $data;
110         read $gro_out, $data, $bytes == $bytes or die "$objname $!";
111         return ($type, $data);
112     } else {
113         die "$objname $l";
114     }
115 }
116
117 sub git_config ($$) {
118     my ($cfgvar, $default) = @_;
119     my ($l, $estatus);
120     run_git(\$estatus, sub { 
121         die if defined $l; 
122         $l = $_; },
123             qw(config), $cfgvar);
124     if (defined $l) {
125         die "$cfgvar ($estatus)" if $estatus;
126         return $l;
127     } else {
128         die "$cfgvar ($estatus)" unless $estatus==0 || $estatus==256;
129         return $default;
130     }
131 }
132
133 sub git_dir () {
134     our $git_dir;
135     if (!defined $git_dir) {
136         $git_dir = run_git_1line(qw(rev-parse --git-dir));
137     }
138     return $git_dir;
139 }
140
141 sub chdir_toplevel () {
142     my $toplevel;
143     run_git(sub { $toplevel = $_; }, 
144             qw(rev-parse --show-toplevel));
145     die "not in working tree?\n" unless defined $toplevel;
146     chdir $toplevel or die "chdir toplevel $toplevel: $!\n";
147 }
148
149 sub current_branch () {
150     open R, git_dir().'/HEAD' or die "open HEAD $!";
151     my $ref = <R>;  defined $ref or die $!;
152     close R;
153     chomp $ref or die;
154     if ($ref !~ s#^ref: ##) {
155         return {
156             Kind => 'detached',
157             Ref => $ref,
158         };
159     }
160     if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
161         return {
162             Kind => $1,
163             Email => $2,
164             Domain => $3,
165             Date => $4,
166             Nick => $', #',
167             Ref => $ref,
168             DepSpec => "$2\@$3/$4/$'",
169         };
170     } elsif ($ref =~ m#^refs/heads/#) {
171         return {
172             Kind => 'foreign',
173             Ref => $ref,
174             DepSpec => "/$ref",
175         };
176     } else {
177         return {
178             Kind => 'weird',
179             Ref => $ref,
180         };
181     }
182 }
183
184 sub parse_patch_name ($) {
185     my ($patch) = @_;
186     my ($eaddr, $date, $nick) = split /\//, $patch, 3;
187     defined $nick && length $nick or die "$patch ?";
188     my ($email, $domain) = $eaddr =~ m/^(.*)\@([^\@]+)$/
189         or die "$patch eaddr ?";
190     return {
191         Email => $email,
192         Domain => $domain,
193         Date => $date,
194         Nick => $nick,
195     };
196 }
197
198 sub parse_patch_spec ($) {
199     my ($orig) = @_;
200     local $_ = $orig;
201     my $spec = { }; # Email Domain DatePrefix DateNear Nick
202     my $set = sub {
203         my ($key,$val,$whats) = @_;
204         die "multiple $whats in patch spec\n" if exists $spec->{$key};
205         $spec->{$key} = $val;
206     };
207     my $rel_levels;
208     for (;;) {
209         if (s#([^/\@]*)\@([^/\@]*)/##) {
210             $set->('Email', $1, "email local parts") if length $1;
211             $set->('Domain', $2, "email domains") if length $1;
212         } elsif (s#([^/]*\~[^/]*)/##) {
213             my $dspec = $1;
214             $dspec =~ y/~/ /;
215             open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
216             my $l = <DATE>;
217             close DATE or die "date parsing failed\n";
218             chomp $l or die;
219             $set->('DateNear', $l, 'nearby dates');
220         } elsif (s#^([0-9][^/]*)/##) {
221             my $dspec = $1;
222             $dspec =~ 
223       m/^\d{4}(?:-\d\d(?:-\d\d(?:T(?:\d\d(?:\d\d(?:\d\d(?:Z)?)?)?)?)?)?)?$/
224                 or die "bad date prefix \`$dspec'\n";
225             $set->('DatePrefix', $dspec, 'date prefixes');
226         } elsif (s#^\./##) {
227             $rel_levels ||= 1;
228         } elsif (s#^\.\./##) {
229             $rel_levels ||= 1;
230             $rel_levels++;
231         } else {
232             last;
233         }
234     }
235     if (defined $rel_levels) {
236         my $branch = current_branch();
237         if (!defined $branch->{Nick}) {
238             die "relative patch spec \`$orig',".
239                 " but current branch not a topbloke patch\n";
240         }
241         my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
242         @l >= $rel_levels or
243             die "relative patch spec \`$orig' has too many ../s\n";
244         $_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
245     } elsif (length) {
246         $spec->{Nick} = $_;
247     }
248     return $spec;
249 }
250
251 sub setup_config () {
252     my (@files) = (qw(msg deps included flags pflags));
253     my $version = 1;
254     foreach my $iteration (qw(0 1)) {
255         foreach my $file (@files) {
256             my $cfgname = "merge.topbloke-$file";
257             my ($current, $current_estatus);
258             run_git(\$current_estatus,
259                     sub { $current = $_; },
260                     qw(config), "$cfgname.driver");
261             $current = "## failed $current_estatus" if $current_estatus;
262             next if $current =~ m/^topbloke-merge-driver --v$version /o;
263             die "$file $current ?" if $iteration;
264             debug("setting merge driver $file");
265             run_git(qw(config), "$cfgname.name",
266                     "topbloke merge driver for $file");
267             run_git(qw(config), "$cfgname.driver",
268                     "topbloke-merge-driver --v$version".
269                     " $file %O %A %B %L");
270         }
271         my ($newattrs, $attrsfile);
272         foreach my $file (@files) {
273             my $path = ".topbloke/$file";
274             my $current = run_git_1line(qw(check-attr merge), $path);
275             $current =~ s#^\Q$path\E: merge: ## or die "$file $current ?";
276             my $want = "topbloke-$file";
277             next if $current eq $want;
278             die "$file $current ?" unless $current eq 'unspecified';
279             die "$file $current ?" if $iteration;
280             if (!$newattrs) {
281                 $attrsfile = git_dir()."/info/attributes";
282                 $newattrs = new IO::File "$attrsfile.tmp", 'w'
283                     or die "$attrsfile.tmp: $!";
284                 if (!open OA, '<', "$attrsfile") {
285                     die "$attrsfile $!" unless $!==&ENOENT;
286                 } else {
287                     while (<OA>) {
288                         print $newattrs $_ or die $!;
289                         print "\n" or die $! unless chomp;
290                     }
291                     die $! if OA->error;
292                     die $! unless close OA;
293                 }
294             }
295             print $newattrs "$path\tmerge=$want\n" or die $!;
296         }
297         last if !$newattrs;
298         close $newattrs or die $!;
299         rename "$attrsfile.tmp", "$attrsfile" or die $!;
300     }
301 }
302
303 sub check_no_unwanted_metadata ($) {
304     # for checking foreign branches aren't contaminated
305     my ($gitbranch) = @_;
306     run_git_check_nooutput('foreign unexpectedly contains',
307                            qw(ls-tree --name-only),
308                            "$gitbranch:",
309                            qw(.topbloke));
310 }
311
312 sub foreach_patch ($$$$) {
313     my ($spec, $deleted_ok, $want, $body) = @_;
314     # runs $body->($fullname, \%flags, \%deps, \%pflags, \%included)
315     #                        $Want->[0]   1        2         3
316     # where $deps->{$fullname} etc. are 1 for true or nonexistent for false
317     #  and if $want->[$item] is not true, the corresponding item may be undef
318     run_git(sub {
319         debug("foreach_patch considering $_");
320         m/ / or die "$_ ?";
321         my $objname = $`;
322         my @out;
323         my $patch = substr($',19); #');
324         push @out, $patch;
325         $want->[0] ||= !$deleted_ok;
326         foreach my $file (qw(flags deps pflags included)) {
327
328             if ($file eq 'deps') {
329                 # do this check after checking for deleted patches,
330                 # so we don't parse deleted patches' names
331                 # right, check the spec next
332                 if ($spec) {
333                     my $have = parse_patch_name($patch);
334                     foreach my $k (qw(Email Domain Nick)) {
335                         debug("foreach_patch  mismatch $k"), return
336                             if defined $spec->{$k} &&
337                                $have->{$k} ne $spec->{$k};
338                     }
339                     debug("foreach_patch  mismatch DatePrefix"), return
340                         if defined $spec->{DatePrefix} &&
341                            substr($have->{Date}, 0, length $spec->{DatePrefix})
342                                ne $spec->{DatePrefix};
343                 }
344             }
345
346             if (!shift @$want) {
347                 push @out, undef;
348                 next;
349             }
350
351             my ($got, $data) = git_get_object("$objname:.topbloke/$file");
352             die "$patch $file ?" unless defined $data;
353             my %data;
354             $data{$_}=1 foreach split /\n/, $data;
355
356             if ($file eq 'flags') {
357                 debug("foreach_patch  Deleted"), return
358                     if !$deleted_ok && $data{Deleted};
359             }
360
361             push @out, \%data;
362         }
363         debug("foreach_patch  YES @out"), return
364         $body->(@out);
365             },
366             qw(for-each-ref --format), '%(objectname) %(refname)',
367                 qw(refs/topbloke-tips));
368 }
369
370 sub flagsfile_add_flag ($$) {
371     # works on "deps" too
372     my ($flagsfile, $flag) = @_;
373     my $wf = wf_start(".topbloke/$flagsfile");
374     open FI, '<', ".topbloke/$flagsfile" or die $!;
375     while (<FI>) {
376         chomp or die;
377         die "flag $flag already set in $flagsfile ?!" if $_ eq $flag;
378         wf($wf, "$_\n");
379     }
380     FI->error and die $!;
381     close FI or die $!;
382     wf($wf, "$flag\n");
383     wf_done($wf);
384 }
385
386 sub wf_start ($) {
387     my ($path) = @_;
388     my $fh = new IO::File "$path.tmp", '>' or die "create $path.tmp: $!\n";
389     return [ $fh, $path ];
390 }
391
392 sub wf ($$) {
393     my ($wf, $data) = @_;
394     my ($fh, $path) = @$wf;
395     print $fh $data or die "write $path.tmp: $!\n";
396 }
397
398 sub wf_abort ($) {
399     my ($wf) = @_;
400     my ($fh, $path) = @$wf;
401     close $fh;
402     unlink "$path.tmp" or die "remove $path.tmp: $!\n";
403 }
404
405 sub wf_done ($) {
406     my ($wf) = @_;
407     my ($fh, $path) = @$wf;
408     close $fh or die "finish writing $path.tmp: $!\n";
409     rename "$path.tmp", $path or die "install new $path: $!\n";
410 }
411
412 sub wf_contents ($$) {
413     my ($path,$contents) = @_;
414     my $wf = wf_start($path);
415     wf($wf, $contents);
416     wf_done($wf);
417 }
418
419 1;