tb-create.pl

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use Getopt::Long;
   7 use Topbloke;
   8
   9 Getopt::Long::Configure(qw(bundling));
  10
  11 die "bad usage\n" unless @ARGV==1;
  12
  13 our $spec = parse_branch_spec($ARGV[0]);
  14 our $current = current_tb_branch();
  15
  16 die "cannot make branch starting at base of another;".
  17     " check out a real branch\n" if $current->{Kind} eq 'base';
  18
  19 die "strange branch ref $current->{Kind} $current->{Ref},\n".
  20     " making new branch with this as dep is unwise\n"
  21     unless ($current->{Kind} eq 'foreign' ||
  22             $current->{Kind} eq 'tip');
  23
  24 sub fillin ($$$) {
  25     my ($key, $newval, $what) = @_;
  26     return if defined $spec->{$key};
  27     $spec->{$key} = $newval;
  28 }
  29
  30 if (!defined $spec->{Email} || !defined $spec->{Domain}) {
  31     my $eaddr = run_git_1line(qw(config user.email));
  32     $eaddr =~ m/^(.*)\@/ or die "$eaddr ?";
  33     fillin('Email',$1,'email domain');
  34     fillin('Domain',$','email domain'); #');
  35 }
  36
  37 if (!defined $spec->{Date}) {
  38     $spec->{Date} = `LC_TIME=C date -u +%Y-%m-%dT%H%M%SZ`;
  39     chomp $spec->{Date} or die $!;
  40 }
  41
  42 length($spec->{Date})==18 or die "partial date specified, not supported\n";
  43
  44 check_no_unwanted_metadata('HEAD')
  45     if $current->{Kind} ne 'tip';
  46
  47 run_git_check_nooutput('cannot create new topbloke branch with staged files',
  48                        qw(diff --cached --name-only HEAD --));
  49
  50 # For the metadata files in .topbloke, we hope that the user
  51 # doesn't modify them.  If they do then they get to keep all the pieces.
  52 #
  53 # For .topbloke/msg, if it's modified by the user (ie, if working
  54 # version differs from HEAD) we keep that and stage it.
  55
  56 my $newbranch = "$spec->{Email}\@$spec->{Domain}/$spec->{Date}/$spec->{Nick}";
  57
  58 $newbranch = run_git_1line(qw(check-ref-format --print), $newbranch);
  59
  60 printf "creating %s\n", $newbranch;
  61
  62 setup_config();
  63
  64 my $user_edited_msg =
  65     run_git_test_anyoutput(qw(diff --name-only HEAD -- .topbloke/msg));
  66
  67 my $baseref = "refs/topbloke-bases/$newbranch";
  68 run_git(qw(update-ref -m), "tb-create base", $baseref, 'HEAD');
  69
  70 open GIT, "|-", 'git', qw(update-index --index-info) or die $!;
  71 foreach my $file (qw(msg deps)) {
  72     run_git(qw(update-index --cacheinfo 0644), $notapplicable_sha1,
  73             ".topbloke/$file");
  74
  75
  76
  77     my $nm = wf_start('.topbloke/msg');
  78     my $author = run_git_1line(qw(var GIT_AUTHOR_IDENT));
  79     $author =~ s/ \d+ [-+]\d+$//;
  80     wf($nm, "From: $author\n");
  81     foreach my $h (qw(To CC BCC)) {
  82         my $estatus;
  83         run_git(\$estatus, sub { wf($nm, "$h: $_") or die $!; },
  84                 qw(config), "topbloke.".lc $h);
  85         die "$h $estatus" unless $estatus==0 || $estatus==256;
  86     }
  87     $subjprefix = git_config('topbloke.subjectprefix', '');
  88     wf($n, <END) or die $!;
  89 Subject: [${subprefix}PATCH] $spec->{Nick}
  90
  91 <patch description>
  92
  93 Signed-off-by: $author
  94 END
  95     wf_done($nm);
  96     run_git(qw(add .topbloke/msg));
  97     print " created and staged new .topbloke/msg\n";
  98 } else {
  99     if (!
 100         print " staged your modified .topbloke/msg\n";
 101         run_git(qw(add .topbloke/msg));
 102     } else {
 103         print " left your (partially staged?) .topbloke/msg\n";
 104     }
 105 }
 106
 107 sub meta_and_stage ($$) {
 108     my ($file, $contents) = @_;
 109     wf_contents(".topbloke/$file", $contents);
 110     run_git(qw(add), ".topbloke/$file");
 111 }
 112
 113 meta_and_stage("deps", $current->{DepSpec}."\n");
 114 meta_and_stage("flags", '');
 115
 116 if ($current->{Kind} eq 'foreign') {
 117     meta_and_stage('included', $current->{DepSpec});
 118