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