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