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_1line {
  29     open GIT, "-|", 'git', @_ or die $!;
  30     my $l = <GIT>;
  31     $?=0;
  32     close GIT or die "git @_ failed ($?)\n";
  33     chomp $l or die "@_ ?";
  34     return $l;
  35 }
  36
  37 sub run_git_1line_estatus {
  38     open GIT, "-|", 'git', @_ or die $!;
  39     my $l = <GIT>;
  40     $?=0;
  41     if (close GIT) {
  42         chomp $l or die "@_ ?";
  43         return (0,$l);
  44     } else {
  45         die unless $?;
  46         return ($?,undef);
  47     }
  48 }
  49
  50 sub run_git_nooutput {
  51     my $rc = system('git', @_);
  52     die "git @_ failed ($rc)" if $rc;
  53 }
  54
  55 sub git_dir () {
  56     our $git_dir;
  57     if (!defined $git_dir) {
  58         $git_dir = run_git_1line(qw(rev-parse --git-dir));
  59     }
  60     return $git_dir;
  61 }
  62
  63 sub current_tb_branch () {
  64     open R, git_dir().'/HEAD' or die "open HEAD $!";
  65     my $ref = <R>;  defined $ref or die $!;
  66     close R;
  67     chomp $ref or die;
  68     if ($ref !~ s#^ref: ##) {
  69         return {
  70             Kind => 'detached',
  71             Ref => $ref,
  72         };
  73     }
  74     if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
  75         return {
  76             Kind => $1,
  77             Email => $2,
  78             Domain => $3,
  79             Date => $4,
  80             Nick => $', #',
  81             Ref => $ref,
  82             DepSpec => "$2\@$3/$4/$'",
  83         };
  84     } elsif ($ref =~ m#^refs/heads/#) {
  85         return {
  86             Kind => 'foreign',
  87             Ref => $ref,
  88             DepSpec => "/$ref",
  89         };
  90     } else {
  91         return {
  92             Kind => 'weird',
  93             Ref => $ref,
  94         };
  95     }
  96 }
  97
  98 sub parse_branch_spec ($) {
  99     my ($orig) = @_;
 100     local $_ = $orig;
 101     my $spec = { }; # Email Domain DatePrefix DateNear Nick
 102     my $set = sub {
 103         my ($key,$val,$whats) = @_;
 104         die "multiple $whats in branch spec\n" if exists $spec->{$key};
 105         $spec->{$key} = $val;
 106     };
 107     my $rel_levels;
 108     for (;;) {
 109         if (s#([^/\@]*)\@([^/\@]*)/##) {
 110             $set->('Email', $1, "email local parts") if length $1;
 111             $set->('Domain', $2, "email domains") if length $1;
 112         } elsif (s#([^/]*\~[^/]*)/##) {
 113             my $dspec = $1;
 114             $dspec =~ y/~/ /;
 115             open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
 116             my $l = <DATE>;
 117             close DATE or die "date parsing failed\n";
 118             chomp $l or die;
 119             $set->('DateNear', $l, 'nearby dates');
 120         } elsif (s#^([0-9][^/]*)/##) {
 121             my $dspec = $1;
 122             $dspec =~
 123       m/^\d{4}(?:-\d\d(?:-\d\d(?:T(?:\d\d(?:\d\d(?:\d\d(?:Z)?)?)?)?)?)?)?$/
 124                 or die "bad date prefix \`$dspec'\n";
 125             $set->('DatePrefix', $dspec, 'date prefixes');
 126         } elsif (s#^\./##) {
 127             $rel_levels ||= 1;
 128         } elsif (s#^\.\./##) {
 129             $rel_levels ||= 1;
 130             $rel_levels++;
 131         } else {
 132             last;
 133         }
 134     }
 135     if (defined $rel_levels) {
 136         my $branch = current_tb_branch();
 137         if (!defined $branch->{Nick}) {
 138             die "relative branch spec \`$orig',".
 139                 " but current branch not a topbloke branch\n";
 140         }
 141         my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
 142         @l >= $rel_levels or
 143             die "relative branch spec \`$orig' has too many ../s\n";
 144         $_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
 145     }
 146     $spec->{Nick} = $_;
 147     return $spec;
 148 }
 149
 150 sub setup_config () {
 151     my (@files) = (qw(msg deps included flags));
 152     my $version = 1;
 153     foreach my $iteration (qw(0 1)) {
 154         foreach my $file (@files) {
 155             my $cfgname = "merge.topbloke-$file";
 156             my ($current_estatus, $current) =
 157                 run_git_1line_estatus(qw(config), "$cfgname.driver");
 158             $current = "## failed $current_estatus" if $current_estatus;
 159             next if $current =~ m/^topbloke-merge-driver --v$version /o;
 160             die "$file $current ?" if $iteration;
 161             debug("setting merge driver $file");
 162             run_git_nooutput(qw(config), "$cfgname.name",
 163                              "topbloke merge driver for $file");
 164             run_git_nooutput(qw(config), "$cfgname.driver",
 165                              "topbloke-merge-driver --v$version".
 166                              " $file %O %A %B %L");
 167         }
 168         my ($newattrs, $attrsfile);
 169         foreach my $file (@files) {
 170             my $path = ".topbloke/$file";
 171             my $current = run_git_1line(qw(check-attr merge), $path);
 172             $current =~ s#^\Q$path\E: merge: ## or die "$file $current ?";
 173             my $want = "topbloke-$file";
 174             next if $current eq $want;
 175             die "$file $current ?" unless $current eq 'unspecified';
 176             die "$file $current ?" if $iteration;
 177             if (!$newattrs) {
 178                 $attrsfile = git_dir()."/info/attributes";
 179                 $newattrs = new IO::File "$attrsfile.tmp", 'w'
 180                     or die "$attrsfile.tmp: $!";
 181                 if (!open OA, '<', "$attrsfile") {
 182                     die "$attrsfile $!" unless $!==&ENOENT;
 183                 } else {
 184                     while (<OA>) {
 185                         print $newattrs $_ or die $!;
 186                         print "\n" or die $! unless chomp;
 187                     }
 188                     die $! if OA->error;
 189                     die $! unless close OA;
 190                 }
 191             }
 192             print $newattrs "$path\tmerge=$want\n" or die $!;
 193         }
 194         last if !$newattrs;
 195         close $newattrs or die $!;
 196         rename "$attrsfile.tmp", "$attrsfile" or die $!;
 197     }
 198 }
 199
 200 sub check_no_unwanted_metadata ($) {
 201     my ($gitbranch) = @_;
 202     open GIT, "-|", 'git', qw(ls-tree --name-status),
 203         "$gitbranch:", qw(.topbloke/included .topbloke/flags)
 204             or die $!;
 205     while (<GIT>) {
 206         chomp or die;
 207         die "foreign unexpectedly contains $_\n";
 208     }
 209     GIT->error and die $!;
 210     close GIT or die $!;
 211 }
 212
 213 1;