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                       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_branch_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 branch 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 branch spec \`$orig',".
 196                 " but current branch not a topbloke branch\n";
 197         }
 198         my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
 199         @l >= $rel_levels or
 200             die "relative branch spec \`$orig' has too many ../s\n";
 201         $_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
 202     }
 203     $spec->{Nick} = $_;
 204     return $spec;
 205 }
 206
 207 sub setup_config () {
 208     my (@files) = (qw(msg deps included flags pflags));
 209     my $version = 1;
 210     foreach my $iteration (qw(0 1)) {
 211         foreach my $file (@files) {
 212             my $cfgname = "merge.topbloke-$file";
 213             my ($current, $current_estatus);
 214             run_git(\$current_estatus,
 215                     sub { $current = $_; },
 216                     qw(config), "$cfgname.driver");
 217             $current = "## failed $current_estatus" if $current_estatus;
 218             next if $current =~ m/^topbloke-merge-driver --v$version /o;
 219             die "$file $current ?" if $iteration;
 220             debug("setting merge driver $file");
 221             run_git(qw(config), "$cfgname.name",
 222                     "topbloke merge driver for $file");
 223             run_git(qw(config), "$cfgname.driver",
 224                     "topbloke-merge-driver --v$version".
 225                     " $file %O %A %B %L");
 226         }
 227         my ($newattrs, $attrsfile);
 228         foreach my $file (@files) {
 229             my $path = ".topbloke/$file";
 230             my $current = run_git_1line(qw(check-attr merge), $path);
 231             $current =~ s#^\Q$path\E: merge: ## or die "$file $current ?";
 232             my $want = "topbloke-$file";
 233             next if $current eq $want;
 234             die "$file $current ?" unless $current eq 'unspecified';
 235             die "$file $current ?" if $iteration;
 236             if (!$newattrs) {
 237                 $attrsfile = git_dir()."/info/attributes";
 238                 $newattrs = new IO::File "$attrsfile.tmp", 'w'
 239                     or die "$attrsfile.tmp: $!";
 240                 if (!open OA, '<', "$attrsfile") {
 241                     die "$attrsfile $!" unless $!==&ENOENT;
 242                 } else {
 243                     while (<OA>) {
 244                         print $newattrs $_ or die $!;
 245                         print "\n" or die $! unless chomp;
 246                     }
 247                     die $! if OA->error;
 248                     die $! unless close OA;
 249                 }
 250             }
 251             print $newattrs "$path\tmerge=$want\n" or die $!;
 252         }
 253         last if !$newattrs;
 254         close $newattrs or die $!;
 255         rename "$attrsfile.tmp", "$attrsfile" or die $!;
 256     }
 257 }
 258
 259 sub check_no_unwanted_metadata ($) {
 260     # for checking foreign branches aren't contaminated
 261     my ($gitbranch) = @_;
 262     run_git_check_nooutput('foreign unexpectedly contains',
 263                            qw(ls-tree --name-only),
 264                            "$gitbranch:",
 265                            qw(.topbloke));
 266 }
 267
 268 sub flagsfile_add_flag ($$) {
 269     # works on "deps" too
 270     my ($flagsfile, $flag) = @_;
 271     my $wf = wf_start(".topbloke/$flagsfile");
 272     open FI, '<', ".topbloke/$flagsfile" or die $!;
 273     while (<FI>) {
 274         chomp or die;
 275         die "flag $flag already set in $flagsfile ?!" if $_ eq $flag;
 276         wf($wf, "$_\n");
 277     }
 278     FI->error and die $!;
 279     close FI or die $!;
 280     wf($wf, "$flag\n");
 281     wf_done($wf);
 282 }
 283
 284 sub wf_start ($) {
 285     my ($path) = @_;
 286     my $fh = new IO::File "$path.tmp", '>' or die "create $path.tmp: $!\n";
 287     return [ $fh, $path ];
 288 }
 289
 290 sub wf ($$) {
 291     my ($wf, $data) = @_;
 292     my ($fh, $path) = @$wf;
 293     print $fh $data or die "write $path.tmp: $!\n";
 294 }
 295
 296 sub wf_abort ($) {
 297     my ($wf) = @_;
 298     my ($fh, $path) = @$wf;
 299     close $fh;
 300     unlink "$path.tmp" or die "remove $path.tmp: $!\n";
 301 }
 302
 303 sub wf_done ($) {
 304     my ($wf) = @_;
 305     my ($fh, $path) = @$wf;
 306     close $fh or die "finish writing $path.tmp: $!\n";
 307     rename "$path.tmp", $path or die "install new $path: $!\n";
 308 }
 309
 310 sub wf_contents ($$) {
 311     my ($path,$contents) = @_;
 312     my $wf = wf_start($path);
 313     wf($wf, $contents);
 314     wf_done($wf);
 315 }
 316
 317 1;