Topbloke.pm

   1 # -*- perl -*-
   2
   3 use strict;
   4 use warnings;
   5
   6 use POSIX;
   7 use IO::File;
   8
   9 package Topbloke;
  10
  11 BEGIN {
  12     use Exporter   ();
  13     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  14
  15     $VERSION     = 1.00;
  16     @ISA         = qw(Exporter);
  17     @EXPORT      = qw(debug
  18                       run_git run_git_1line run_git_check_nooutput
  19                       run_git_test_anyoutput
  20                       git_config git_dir chdir_toplevel
  21                       current_branch parse_patch_spec
  22                       setup_config check_no_unwanted_metadata
  23                       flagsfile_add_flag
  24                       wf_start wf wf_abort wf_done wf_contents);
  25     %EXPORT_TAGS = ( );
  26     @EXPORT_OK   = qw();
  27 }
  28
  29 our $git_command = 'git';
  30
  31 sub debug ($) {
  32     my ($msg) = @_;
  33     print STDERR "DEBUG: $msg\n" or die $!;
  34 }
  35
  36 sub run_git {
  37     # takes optional prefix arguments:
  38     #    coderef    hook to call for each line read,
  39     #                with $_ containing chomped line; if not supplied,
  40     #                output is not read
  41     #    scalarref  place to store exit status; if not supplied,
  42     #                nonzero exit status is fatal
  43     my ($estatusr,$linecallr);
  44     while (ref $_[0]) {
  45         my $ref = shift @_;
  46         if (ref $ref eq 'SCALAR') {
  47             $estatusr = $ref;
  48         } elsif (ref $ref eq 'CODE') {
  49             $linecallr = $ref;
  50         } else {
  51             die ref($ref)." @_ ?";
  52         }
  53     }
  54     open GIT, "-|", $git_command, @_ or die $!;
  55     if ($linecallr) {
  56         while (<GIT>) {
  57             chomp or die "$git_command @_ gave $_ ?";
  58             $linecallr->();
  59         }
  60         GIT->eof or die $!;
  61     }
  62     if (!close GIT) {
  63         die "$git_command @_ $!" if $!;
  64         die unless $?;
  65         die "$git_command @_ ($?)" unless $estatusr;
  66         $$estatusr = $?;
  67     } else {
  68         $$estatusr = 0 if $estatusr;
  69     }
  70 }
  71
  72 sub run_git_1line {
  73     my $l;
  74     run_git(sub { $l = $_; }, @_);
  75     die "git @_ ?" unless defined $l;
  76     return $l;
  77 }
  78
  79 sub run_git_check_nooutput {
  80     my ($what) = shift @_;
  81     run_git(sub { die "$what $_\n"; }, @_);
  82 }
  83
  84 sub run_git_test_anyoutput {
  85     my $any = 0;
  86     run_git(sub { $any=1; }, @_);
  87     return $any;
  88 }
  89
  90 sub git_config ($$) {
  91     my ($cfgvar, $default) = @_;
  92     my ($l, $estatus);
  93     run_git(\$estatus, sub {
  94         die if defined $l;
  95         $l = $_; },
  96             qw(config), $cfgvar);
  97     if (defined $l) {
  98         die "$cfgvar ($estatus)" if $estatus;
  99         return $l;
 100     } else {
 101         die "$cfgvar ($estatus)" unless $estatus==0 || $estatus==256;
 102         return $default;
 103     }
 104 }
 105
 106 sub git_dir () {
 107     our $git_dir;
 108     if (!defined $git_dir) {
 109         $git_dir = run_git_1line(qw(rev-parse --git-dir));
 110     }
 111     return $git_dir;
 112 }
 113
 114 sub chdir_toplevel () {
 115     my $toplevel;
 116     run_git(sub { $toplevel = $_; },
 117             qw(rev-parse --show-toplevel));
 118     die "not in working tree?\n" unless defined $toplevel;
 119     chdir $toplevel or die "chdir toplevel $toplevel: $!\n";
 120 }
 121
 122 sub current_branch () {
 123     open R, git_dir().'/HEAD' or die "open HEAD $!";
 124     my $ref = <R>;  defined $ref or die $!;
 125     close R;
 126     chomp $ref or die;
 127     if ($ref !~ s#^ref: ##) {
 128         return {
 129             Kind => 'detached',
 130             Ref => $ref,
 131         };
 132     }
 133     if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
 134         return {
 135             Kind => $1,
 136             Email => $2,
 137             Domain => $3,
 138             Date => $4,
 139             Nick => $', #',
 140             Ref => $ref,
 141             DepSpec => "$2\@$3/$4/$'",
 142         };
 143     } elsif ($ref =~ m#^refs/heads/#) {
 144         return {
 145             Kind => 'foreign',
 146             Ref => $ref,
 147             DepSpec => "/$ref",
 148         };
 149     } else {
 150         return {
 151             Kind => 'weird',
 152             Ref => $ref,
 153         };
 154     }
 155 }
 156
 157 sub parse_patch_spec ($) {
 158     my ($orig) = @_;
 159     local $_ = $orig;
 160     my $spec = { }; # Email Domain DatePrefix DateNear Nick
 161     my $set = sub {
 162         my ($key,$val,$whats) = @_;
 163         die "multiple $whats in patch spec\n" if exists $spec->{$key};
 164         $spec->{$key} = $val;
 165     };
 166     my $rel_levels;
 167     for (;;) {
 168         if (s#([^/\@]*)\@([^/\@]*)/##) {
 169             $set->('Email', $1, "email local parts") if length $1;
 170             $set->('Domain', $2, "email domains") if length $1;
 171         } elsif (s#([^/]*\~[^/]*)/##) {
 172             my $dspec = $1;
 173             $dspec =~ y/~/ /;
 174             open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
 175             my $l = <DATE>;
 176             close DATE or die "date parsing failed\n";
 177             chomp $l or die;
 178             $set->('DateNear', $l, 'nearby dates');
 179         } elsif (s#^([0-9][^/]*)/##) {
 180             my $dspec = $1;
 181             $dspec =~
 182       m/^\d{4}(?:-\d\d(?:-\d\d(?:T(?:\d\d(?:\d\d(?:\d\d(?:Z)?)?)?)?)?)?)?$/
 183                 or die "bad date prefix \`$dspec'\n";
 184             $set->('DatePrefix', $dspec, 'date prefixes');
 185         } elsif (s#^\./##) {
 186             $rel_levels ||= 1;
 187         } elsif (s#^\.\./##) {
 188             $rel_levels ||= 1;
 189             $rel_levels++;
 190         } else {
 191             last;
 192         }
 193     }
 194     if (defined $rel_levels) {
 195         my $branch = current_branch();
 196         if (!defined $branch->{Nick}) {
 197             die "relative patch spec \`$orig',".
 198                 " but current branch not a topbloke patch\n";
 199         }
 200         my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
 201         @l >= $rel_levels or
 202             die "relative patch spec \`$orig' has too many ../s\n";
 203         $_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
 204     } elsif (length) {
 205         $spec->{Nick} = $_;
 206     }
 207     return $spec;
 208 }
 209
 210 sub setup_config () {
 211     my (@files) = (qw(msg deps included flags pflags));
 212     my $version = 1;
 213     foreach my $iteration (qw(0 1)) {
 214         foreach my $file (@files) {
 215             my $cfgname = "merge.topbloke-$file";
 216             my ($current, $current_estatus);
 217             run_git(\$current_estatus,
 218                     sub { $current = $_; },
 219                     qw(config), "$cfgname.driver");
 220             $current = "## failed $current_estatus" if $current_estatus;
 221             next if $current =~ m/^topbloke-merge-driver --v$version /o;
 222             die "$file $current ?" if $iteration;
 223             debug("setting merge driver $file");
 224             run_git(qw(config), "$cfgname.name",
 225                     "topbloke merge driver for $file");
 226             run_git(qw(config), "$cfgname.driver",
 227                     "topbloke-merge-driver --v$version".
 228                     " $file %O %A %B %L");
 229         }
 230         my ($newattrs, $attrsfile);
 231         foreach my $file (@files) {
 232             my $path = ".topbloke/$file";
 233             my $current = run_git_1line(qw(check-attr merge), $path);
 234             $current =~ s#^\Q$path\E: merge: ## or die "$file $current ?";
 235             my $want = "topbloke-$file";
 236             next if $current eq $want;
 237             die "$file $current ?" unless $current eq 'unspecified';
 238             die "$file $current ?" if $iteration;
 239             if (!$newattrs) {
 240                 $attrsfile = git_dir()."/info/attributes";
 241                 $newattrs = new IO::File "$attrsfile.tmp", 'w'
 242                     or die "$attrsfile.tmp: $!";
 243                 if (!open OA, '<', "$attrsfile") {
 244                     die "$attrsfile $!" unless $!==&ENOENT;
 245                 } else {
 246                     while (<OA>) {
 247                         print $newattrs $_ or die $!;
 248                         print "\n" or die $! unless chomp;
 249                     }
 250                     die $! if OA->error;
 251                     die $! unless close OA;
 252                 }
 253             }
 254             print $newattrs "$path\tmerge=$want\n" or die $!;
 255         }
 256         last if !$newattrs;
 257         close $newattrs or die $!;
 258         rename "$attrsfile.tmp", "$attrsfile" or die $!;
 259     }
 260 }
 261
 262 sub check_no_unwanted_metadata ($) {
 263     # for checking foreign branches aren't contaminated
 264     my ($gitbranch) = @_;
 265     run_git_check_nooutput('foreign unexpectedly contains',
 266                            qw(ls-tree --name-only),
 267                            "$gitbranch:",
 268                            qw(.topbloke));
 269 }
 270
 271 sub flagsfile_add_flag ($$) {
 272     # works on "deps" too
 273     my ($flagsfile, $flag) = @_;
 274     my $wf = wf_start(".topbloke/$flagsfile");
 275     open FI, '<', ".topbloke/$flagsfile" or die $!;
 276     while (<FI>) {
 277         chomp or die;
 278         die "flag $flag already set in $flagsfile ?!" if $_ eq $flag;
 279         wf($wf, "$_\n");
 280     }
 281     FI->error and die $!;
 282     close FI or die $!;
 283     wf($wf, "$flag\n");
 284     wf_done($wf);
 285 }
 286
 287 sub wf_start ($) {
 288     my ($path) = @_;
 289     my $fh = new IO::File "$path.tmp", '>' or die "create $path.tmp: $!\n";
 290     return [ $fh, $path ];
 291 }
 292
 293 sub wf ($$) {
 294     my ($wf, $data) = @_;
 295     my ($fh, $path) = @$wf;
 296     print $fh $data or die "write $path.tmp: $!\n";
 297 }
 298
 299 sub wf_abort ($) {
 300     my ($wf) = @_;
 301     my ($fh, $path) = @$wf;
 302     close $fh;
 303     unlink "$path.tmp" or die "remove $path.tmp: $!\n";
 304 }
 305
 306 sub wf_done ($) {
 307     my ($wf) = @_;
 308     my ($fh, $path) = @$wf;
 309     close $fh or die "finish writing $path.tmp: $!\n";
 310     rename "$path.tmp", $path or die "install new $path: $!\n";
 311 }
 312
 313 sub wf_contents ($$) {
 314     my ($path,$contents) = @_;
 315     my $wf = wf_start($path);
 316     wf($wf, $contents);
 317     wf_done($wf);
 318 }
 319
 320 1;