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