13 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
17 @EXPORT = qw(parse_branch_spec current_tb_branch run_git_1line
25 print STDERR "DEBUG: $msg\n" or die $!;
29 open GIT, "-|", 'git', @_ or die $!;
32 close GIT or die "git @_ failed ($?)\n";
33 chomp $l or die "@_ ?";
37 sub run_git_1line_estatus {
38 open GIT, "-|", 'git', @_ or die $!;
42 chomp $l or die "@_ ?";
50 sub run_git_nooutput {
51 my $rc = system('git', @_);
52 die "git @_ failed ($rc)" if $rc;
57 if (!defined $git_dir) {
58 $git_dir = run_git_1line(qw(rev-parse --git-dir));
63 sub current_tb_branch () {
64 open R, git_dir().'/HEAD' or die "open HEAD $!";
65 my $ref = <R>; defined $ref or die $!;
68 if ($ref !~ s#^ref: ##) {
74 if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
82 DepSpec => "$2\@$3/$4/$'",
84 } elsif ($ref =~ m#^refs/heads/#) {
98 sub parse_branch_spec ($) {
101 my $spec = { }; # Email Domain DatePrefix DateNear Nick
103 my ($key,$val,$whats) = @_;
104 die "multiple $whats in branch spec\n" if exists $spec->{$key};
105 $spec->{$key} = $val;
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#([^/]*\~[^/]*)/##) {
115 open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
117 close DATE or die "date parsing failed\n";
119 $set->('DateNear', $l, 'nearby dates');
120 } elsif (s#^([0-9][^/]*)/##) {
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');
128 } elsif (s#^\.\./##) {
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";
141 my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
143 die "relative branch spec \`$orig' has too many ../s\n";
144 $_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
150 sub setup_config () {
151 my (@files) = (qw(msg deps included flags));
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");
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;
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;
185 print $newattrs $_ or die $!;
186 print "\n" or die $! unless chomp;
189 die $! unless close OA;
193 print $newattrs "$path\tmerge=$want\n" or die $!;
196 close $newattrs or die $!;
197 rename "$attrsfile.tmp", "$attrsfile" or die $!;