git-archimport.perl

   1 #!/usr/bin/perl -w
   2 #
   3 # This tool is copyright (c) 2005, Martin Langhoff.
   4 # It is released under the Gnu Public License, version 2.
   5 #
   6 # The basic idea is to walk the output of tla abrowse,
   7 # fetch the changesets and apply them.
   8 #
   9
  10 =head1 Invocation
  11
  12     git-archimport [ -h ] [ -v ] [ -T ] [ -t tempdir ] <archive>/<branch> [ <archive>/<branch> ]
  13
  14 Imports a project from one or more Arch repositories. It will follow branches
  15 and repositories within the namespaces defined by the <archive/branch>
  16 parameters suppplied. If it cannot find the remote branch a merge comes from
  17 it will just import it as a regular commit. If it can find it, it will mark it
  18 as a merge whenever possible.
  19
  20 See man (1) git-archimport for more details.
  21
  22 =head1 TODO
  23
  24  - create tag objects instead of ref tags
  25  - audit shell-escaping of filenames
  26  - hide our private tags somewhere smarter
  27  - find a way to make "cat *patches | patch" safe even when patchfiles are missing newlines
  28
  29 =head1 Devel tricks
  30
  31 Add print in front of the shell commands invoked via backticks.
  32
  33 =head1 Devel Notes
  34
  35 There are several places where Arch and git terminology are intermixed
  36 and potentially confused.
  37
  38 The notion of a "branch" in git is approximately equivalent to
  39 a "archive/category--branch--version" in Arch.  Also, it should be noted
  40 that the "--branch" portion of "archive/category--branch--version" is really
  41 optional in Arch although not many people (nor tools!) seem to know this.
  42 This means that "archive/category--version" is also a valid "branch"
  43 in git terms.
  44
  45 We always refer to Arch names by their fully qualified variant (which
  46 means the "archive" name is prefixed.
  47
  48 For people unfamiliar with Arch, an "archive" is the term for "repository",
  49 and can contain multiple, unrelated branches.
  50
  51 =cut
  52
  53 use strict;
  54 use warnings;
  55 use Getopt::Std;
  56 use File::Spec;
  57 use File::Temp qw(tempfile tempdir);
  58 use File::Path qw(mkpath);
  59 use File::Basename qw(basename dirname);
  60 use String::ShellQuote;
  61 use Time::Local;
  62 use IO::Socket;
  63 use IO::Pipe;
  64 use POSIX qw(strftime dup2);
  65 use Data::Dumper qw/ Dumper /;
  66 use IPC::Open2;
  67
  68 $SIG{'PIPE'}="IGNORE";
  69 $ENV{'TZ'}="UTC";
  70
  71 my $git_dir = $ENV{"GIT_DIR"} || ".git";
  72 $ENV{"GIT_DIR"} = $git_dir;
  73 my $ptag_dir = "$git_dir/archimport/tags";
  74
  75 our($opt_h,$opt_v, $opt_T,$opt_t,$opt_o);
  76
  77 sub usage() {
  78     print STDERR <<END;
  79 Usage: ${\basename $0}     # fetch/update GIT from Arch
  80        [ -o ] [ -h ] [ -v ] [ -T ] [ -t tempdir ]
  81        repository/arch-branch [ repository/arch-branch] ...
  82 END
  83     exit(1);
  84 }
  85
  86 getopts("Thvt:") or usage();
  87 usage if $opt_h;
  88
  89 @ARGV >= 1 or usage();
  90 my @arch_roots = @ARGV;
  91
  92 my ($tmpdir, $tmpdirname) = tempdir('git-archimport-XXXXXX', TMPDIR => 1, CLEANUP => 1);
  93 my $tmp = $opt_t || 1;
  94 $tmp = tempdir('git-archimport-XXXXXX', TMPDIR => 1, CLEANUP => 1);
  95 $opt_v && print "+ Using $tmp as temporary directory\n";
  96
  97 my @psets  = ();                # the collection
  98 my %psets  = ();                # the collection, by name
  99
 100 my %rptags = ();                # my reverse private tags
 101                                 # to map a SHA1 to a commitid
 102
 103 foreach my $root (@arch_roots) {
 104     my ($arepo, $abranch) = split(m!/!, $root);
 105     open ABROWSE, "tla abrowse -f -A $arepo --desc --merges $abranch |"
 106         or die "Problems with tla abrowse: $!";
 107
 108     my %ps        = ();         # the current one
 109     my $mode      = '';
 110     my $lastseen  = '';
 111
 112     while (<ABROWSE>) {
 113         chomp;
 114
 115         # first record padded w 8 spaces
 116         if (s/^\s{8}\b//) {
 117
 118             # store the record we just captured
 119             if (%ps) {
 120                 my %temp = %ps; # break references
 121                 push (@psets, \%temp);
 122                 $psets{$temp{id}} = \%temp;
 123                 %ps = ();
 124             }
 125
 126             my ($id, $type) = split(m/\s{3}/, $_);
 127             $ps{id}   = $id;
 128             $ps{repo} = $arepo;
 129
 130             # deal with types
 131             if ($type =~ m/^\(simple changeset\)/) {
 132                 $ps{type} = 's';
 133             } elsif ($type eq '(initial import)') {
 134                 $ps{type} = 'i';
 135             } elsif ($type =~ m/^\(tag revision of (.+)\)/) {
 136                 $ps{type} = 't';
 137                 $ps{tag}  = $1;
 138             } else {
 139                 warn "Unknown type $type";
 140             }
 141             $lastseen = 'id';
 142         }
 143
 144         if (s/^\s{10}//) {
 145             # 10 leading spaces or more
 146             # indicate commit metadata
 147
 148             # date & author
 149             if ($lastseen eq 'id' && m/^\d{4}-\d{2}-\d{2}/) {
 150
 151                 my ($date, $authoremail) = split(m/\s{2,}/, $_);
 152                 $ps{date}   = $date;
 153                 $ps{date}   =~ s/\bGMT$//; # strip off trailign GMT
 154                 if ($ps{date} =~ m/\b\w+$/) {
 155                     warn 'Arch dates not in GMT?! - imported dates will be wrong';
 156                 }
 157
 158                 $authoremail =~ m/^(.+)\s(\S+)$/;
 159                 $ps{author} = $1;
 160                 $ps{email}  = $2;
 161
 162                 $lastseen = 'date';
 163
 164             } elsif ($lastseen eq 'date') {
 165                 # the only hint is position
 166                 # subject is after date
 167                 $ps{subj} = $_;
 168                 $lastseen = 'subj';
 169
 170             } elsif ($lastseen eq 'subj' && $_ eq 'merges in:') {
 171                 $ps{merges} = [];
 172                 $lastseen = 'merges';
 173
 174             } elsif ($lastseen eq 'merges' && s/^\s{2}//) {
 175                 push (@{$ps{merges}}, $_);
 176             } else {
 177                 warn 'more metadata after merges!?';
 178             }
 179
 180         }
 181     }
 182
 183     if (%ps) {
 184         my %temp = %ps;         # break references
 185         push (@psets, \%temp);
 186         $psets{ $temp{id} } = \%temp;
 187         %ps = ();
 188     }
 189     close ABROWSE;
 190 }                               # end foreach $root
 191
 192 ## Order patches by time
 193 @psets = sort {$a->{date}.$b->{id} cmp $b->{date}.$b->{id}} @psets;
 194
 195 #print Dumper \@psets;
 196
 197 ##
 198 ## TODO cleanup irrelevant patches
 199 ##      and put an initial import
 200 ##      or a full tag
 201 my $import = 0;
 202 unless (-d $git_dir) { # initial import
 203     if ($psets[0]{type} eq 'i' || $psets[0]{type} eq 't') {
 204         print "Starting import from $psets[0]{id}\n";
 205         `git-init-db`;
 206         die $! if $?;
 207         $import = 1;
 208     } else {
 209         die "Need to start from an import or a tag -- cannot use $psets[0]{id}";
 210     }
 211 } else {    # progressing an import
 212     # load the rptags
 213     opendir(DIR, "$git_dir/archimport/tags")
 214         || die "can't opendir: $!";
 215     while (my $file = readdir(DIR)) {
 216         # skip non-interesting-files
 217         next unless -f "$ptag_dir/$file";
 218
 219         # convert first '--' to '/' from old git-archimport to use
 220         # as an archivename/c--b--v private tag
 221         if ($file !~ m!,!) {
 222             my $oldfile = $file;
 223             $file =~ s!--!,!;
 224             print STDERR "converting old tag $oldfile to $file\n";
 225             rename("$ptag_dir/$oldfile", "$ptag_dir/$file") or die $!;
 226         }
 227         my $sha = ptag($file);
 228         chomp $sha;
 229         $rptags{$sha} = $file;
 230     }
 231     closedir DIR;
 232 }
 233
 234 # process patchsets
 235 # extract the Arch repository name (Arch "archive" in Arch-speak)
 236 sub extract_reponame {
 237     my $fq_cvbr = shift; # archivename/[[[[category]branch]version]revision]
 238     return (split(/\//, $fq_cvbr))[0];
 239 }
 240
 241 sub extract_versionname {
 242     my $name = shift;
 243     $name =~ s/--(?:patch|version(?:fix)?|base)-\d+$//;
 244     return $name;
 245 }
 246
 247 # convert a fully-qualified revision or version to a unique dirname:
 248 #   normalperson@yhbt.net-05/mpd--uclinux--1--patch-2
 249 # becomes: normalperson@yhbt.net-05,mpd--uclinux--1
 250 #
 251 # the git notion of a branch is closer to
 252 # archive/category--branch--version than archive/category--branch, so we
 253 # use this to convert to git branch names.
 254 # Also, keep archive names but replace '/' with ',' since it won't require
 255 # subdirectories, and is safer than swapping '--' which could confuse
 256 # reverse-mapping when dealing with bastard branches that
 257 # are just archive/category--version  (no --branch)
 258 sub tree_dirname {
 259     my $revision = shift;
 260     my $name = extract_versionname($revision);
 261     $name =~ s#/#,#;
 262     return $name;
 263 }
 264
 265 # old versions of git-archimport just use the <category--branch> part:
 266 sub old_style_branchname {
 267     my $id = shift;
 268     my $ret = safe_pipe_capture($TLA,'parse-package-name','-p',$id);
 269     chomp $ret;
 270     return $ret;
 271 }
 272
 273 *git_branchname = $opt_o ? *old_style_branchname : *tree_dirname;
 274
 275 # process patchsets
 276 foreach my $ps (@psets) {
 277     $ps->{branch} = git_branchname($ps->{id});
 278
 279     #
 280     # ensure we have a clean state
 281     #
 282     if (`git diff-files`) {
 283         die "Unclean tree when about to process $ps->{id} " .
 284             " - did we fail to commit cleanly before?";
 285     }
 286     die $! if $?;
 287
 288     #
 289     # skip commits already in repo
 290     #
 291     if (ptag($ps->{id})) {
 292       $opt_v && print " * Skipping already imported: $ps->{id}\n";
 293       next;
 294     }
 295
 296     print " * Starting to work on $ps->{id}\n";
 297
 298     #
 299     # create the branch if needed
 300     #
 301     if ($ps->{type} eq 'i' && !$import) {
 302         die "Should not have more than one 'Initial import' per GIT import: $ps->{id}";
 303     }
 304
 305     unless ($import) { # skip for import
 306         if ( -e "$git_dir/refs/heads/$ps->{branch}") {
 307             # we know about this branch
 308             `git checkout    $ps->{branch}`;
 309         } else {
 310             # new branch! we need to verify a few things
 311             die "Branch on a non-tag!" unless $ps->{type} eq 't';
 312             my $branchpoint = ptag($ps->{tag});
 313             die "Tagging from unknown id unsupported: $ps->{tag}"
 314                 unless $branchpoint;
 315
 316             # find where we are supposed to branch from
 317             `git checkout -b $ps->{branch} $branchpoint`;
 318
 319             # If we trust Arch with the fact that this is just
 320             # a tag, and it does not affect the state of the tree
 321             # then we just tag and move on
 322             tag($ps->{id}, $branchpoint);
 323             ptag($ps->{id}, $branchpoint);
 324             print " * Tagged $ps->{id} at $branchpoint\n";
 325             next;
 326         }
 327         die $! if $?;
 328     }
 329
 330     #
 331     # Apply the import/changeset/merge into the working tree
 332     #
 333     if ($ps->{type} eq 'i' || $ps->{type} eq 't') {
 334         apply_import($ps) or die $!;
 335         $import=0;
 336     } elsif ($ps->{type} eq 's') {
 337         apply_cset($ps);
 338     }
 339
 340     #
 341     # prepare update git's index, based on what arch knows
 342     # about the pset, resolve parents, etc
 343     #
 344     my $tree;
 345
 346     my $commitlog = `tla cat-archive-log -A $ps->{repo} $ps->{id}`;
 347     die "Error in cat-archive-log: $!" if $?;
 348
 349     # parselog will git-add/rm files
 350     # and generally prepare things for the commit
 351     # NOTE: parselog will shell-quote filenames!
 352     my ($sum, $msg, $add, $del, $mod, $ren) = parselog($commitlog);
 353     my $logmessage = "$sum\n$msg";
 354
 355
 356     # imports don't give us good info
 357     # on added files. Shame on them
 358     if ($ps->{type} eq 'i' || $ps->{type} eq 't') {
 359         `find . -type f -print0 | grep -zv '^./$git_dir' | xargs -0 -l100 git-update-index --add`;
 360         `git-ls-files --deleted -z | xargs --no-run-if-empty -0 -l100 git-update-index --remove`;
 361     }
 362
 363     if (@$add) {
 364         while (@$add) {
 365             my @slice = splice(@$add, 0, 100);
 366             my $slice = join(' ', @slice);
 367             `git-update-index --add $slice`;
 368             die "Error in git-update-index --add: $!" if $?;
 369         }
 370     }
 371     if (@$del) {
 372         foreach my $file (@$del) {
 373             unlink $file or die "Problems deleting $file : $!";
 374         }
 375         while (@$del) {
 376             my @slice = splice(@$del, 0, 100);
 377             my $slice = join(' ', @slice);
 378             `git-update-index --remove $slice`;
 379             die "Error in git-update-index --remove: $!" if $?;
 380         }
 381     }
 382     if (@$ren) {                # renamed
 383         if (@$ren % 2) {
 384             die "Odd number of entries in rename!?";
 385         }
 386         ;
 387         while (@$ren) {
 388             my $from = pop @$ren;
 389             my $to   = pop @$ren;
 390
 391             unless (-d dirname($to)) {
 392                 mkpath(dirname($to)); # will die on err
 393             }
 394             #print "moving $from $to";
 395             `mv $from $to`;
 396             die "Error renaming $from $to : $!" if $?;
 397             `git-update-index --remove $from`;
 398             die "Error in git-update-index --remove: $!" if $?;
 399             `git-update-index --add $to`;
 400             die "Error in git-update-index --add: $!" if $?;
 401         }
 402
 403     }
 404     if (@$mod) {                # must be _after_ renames
 405         while (@$mod) {
 406             my @slice = splice(@$mod, 0, 100);
 407             my $slice = join(' ', @slice);
 408             `git-update-index $slice`;
 409             die "Error in git-update-index: $!" if $?;
 410         }
 411     }
 412
 413     # warn "errors when running git-update-index! $!";
 414     $tree = `git-write-tree`;
 415     die "cannot write tree $!" if $?;
 416     chomp $tree;
 417
 418
 419     #
 420     # Who's your daddy?
 421     #
 422     my @par;
 423     if ( -e "$git_dir/refs/heads/$ps->{branch}") {
 424         if (open HEAD, "<$git_dir/refs/heads/$ps->{branch}") {
 425             my $p = <HEAD>;
 426             close HEAD;
 427             chomp $p;
 428             push @par, '-p', $p;
 429         } else {
 430             if ($ps->{type} eq 's') {
 431                 warn "Could not find the right head for the branch $ps->{branch}";
 432             }
 433         }
 434     }
 435
 436     if ($ps->{merges}) {
 437         push @par, find_parents($ps);
 438     }
 439     my $par = join (' ', @par);
 440
 441     #
 442     # Commit, tag and clean state
 443     #
 444     $ENV{TZ}                  = 'GMT';
 445     $ENV{GIT_AUTHOR_NAME}     = $ps->{author};
 446     $ENV{GIT_AUTHOR_EMAIL}    = $ps->{email};
 447     $ENV{GIT_AUTHOR_DATE}     = $ps->{date};
 448     $ENV{GIT_COMMITTER_NAME}  = $ps->{author};
 449     $ENV{GIT_COMMITTER_EMAIL} = $ps->{email};
 450     $ENV{GIT_COMMITTER_DATE}  = $ps->{date};
 451
 452     my ($pid, $commit_rh, $commit_wh);
 453     $commit_rh = 'commit_rh';
 454     $commit_wh = 'commit_wh';
 455
 456     $pid = open2(*READER, *WRITER, "git-commit-tree $tree $par")
 457         or die $!;
 458     print WRITER $logmessage;   # write
 459     close WRITER;
 460     my $commitid = <READER>;    # read
 461     chomp $commitid;
 462     close READER;
 463     waitpid $pid,0;             # close;
 464
 465     if (length $commitid != 40) {
 466         die "Something went wrong with the commit! $! $commitid";
 467     }
 468     #
 469     # Update the branch
 470     #
 471     open  HEAD, ">$git_dir/refs/heads/$ps->{branch}";
 472     print HEAD $commitid;
 473     close HEAD;
 474     system('git-update-ref', 'HEAD', "$ps->{branch}");
 475
 476     # tag accordingly
 477     ptag($ps->{id}, $commitid); # private tag
 478     if ($opt_T || $ps->{type} eq 't' || $ps->{type} eq 'i') {
 479         tag($ps->{id}, $commitid);
 480     }
 481     print " * Committed $ps->{id}\n";
 482     print "   + tree   $tree\n";
 483     print "   + commit $commitid\n";
 484     $opt_v && print "   + commit date is  $ps->{date} \n";
 485     $opt_v && print "   + parents:  $par \n";
 486 }
 487
 488 sub apply_import {
 489     my $ps = shift;
 490     my $bname = git_branchname($ps->{id});
 491
 492     `mkdir -p $tmp`;
 493
 494     `tla get -s --no-pristine -A $ps->{repo} $ps->{id} $tmp/import`;
 495     die "Cannot get import: $!" if $?;
 496     `rsync -v --archive --delete --exclude '$git_dir' --exclude '.arch-ids' --exclude '{arch}' $tmp/import/* ./`;
 497     die "Cannot rsync import:$!" if $?;
 498
 499     `rm -fr $tmp/import`;
 500     die "Cannot remove tempdir: $!" if $?;
 501
 502
 503     return 1;
 504 }
 505
 506 sub apply_cset {
 507     my $ps = shift;
 508
 509     `mkdir -p $tmp`;
 510
 511     # get the changeset
 512     `tla get-changeset  -A $ps->{repo} $ps->{id} $tmp/changeset`;
 513     die "Cannot get changeset: $!" if $?;
 514
 515     # apply patches
 516     if (`find $tmp/changeset/patches -type f -name '*.patch'`) {
 517         # this can be sped up considerably by doing
 518         #    (find | xargs cat) | patch
 519         # but that cna get mucked up by patches
 520         # with missing trailing newlines or the standard
 521         # 'missing newline' flag in the patch - possibly
 522         # produced with an old/buggy diff.
 523         # slow and safe, we invoke patch once per patchfile
 524         `find $tmp/changeset/patches -type f -name '*.patch' -print0 | grep -zv '{arch}' | xargs -iFILE -0 --no-run-if-empty patch -p1 --forward -iFILE`;
 525         die "Problem applying patches! $!" if $?;
 526     }
 527
 528     # apply changed binary files
 529     if (my @modified = `find $tmp/changeset/patches -type f -name '*.modified'`) {
 530         foreach my $mod (@modified) {
 531             chomp $mod;
 532             my $orig = $mod;
 533             $orig =~ s/\.modified$//; # lazy
 534             $orig =~ s!^\Q$tmp\E/changeset/patches/!!;
 535             #print "rsync -p '$mod' '$orig'";
 536             `rsync -p $mod ./$orig`;
 537             die "Problem applying binary changes! $!" if $?;
 538         }
 539     }
 540
 541     # bring in new files
 542     `rsync --archive --exclude '$git_dir' --exclude '.arch-ids' --exclude '{arch}' $tmp/changeset/new-files-archive/* ./`;
 543
 544     # deleted files are hinted from the commitlog processing
 545
 546     `rm -fr $tmp/changeset`;
 547 }
 548
 549
 550 # =for reference
 551 # A log entry looks like
 552 # Revision: moodle-org--moodle--1.3.3--patch-15
 553 # Archive: arch-eduforge@catalyst.net.nz--2004
 554 # Creator: Penny Leach <penny@catalyst.net.nz>
 555 # Date: Wed May 25 14:15:34 NZST 2005
 556 # Standard-date: 2005-05-25 02:15:34 GMT
 557 # New-files: lang/de/.arch-ids/block_glossary_random.php.id
 558 #     lang/de/.arch-ids/block_html.php.id
 559 # New-directories: lang/de/help/questionnaire
 560 #     lang/de/help/questionnaire/.arch-ids
 561 # Renamed-files: .arch-ids/db_sears.sql.id db/.arch-ids/db_sears.sql.id
 562 #    db_sears.sql db/db_sears.sql
 563 # Removed-files: lang/be/docs/.arch-ids/release.html.id
 564 #     lang/be/docs/.arch-ids/releaseold.html.id
 565 # Modified-files: admin/cron.php admin/delete.php
 566 #     admin/editor.html backup/lib.php backup/restore.php
 567 # New-patches: arch-eduforge@catalyst.net.nz--2004/moodle-org--moodle--1.3.3--patch-15
 568 # Summary: Updating to latest from MOODLE_14_STABLE (1.4.5+)
 569 # Keywords:
 570 #
 571 # Updating yadda tadda tadda madda
 572 sub parselog {
 573     my $log = shift;
 574     #print $log;
 575
 576     my (@add, @del, @mod, @ren, @kw, $sum, $msg );
 577
 578     if ($log =~ m/(?:\n|^)New-files:(.*?)(?=\n\w)/s ) {
 579         my $files = $1;
 580         @add = split(m/\s+/s, $files);
 581     }
 582
 583     if ($log =~ m/(?:\n|^)Removed-files:(.*?)(?=\n\w)/s ) {
 584         my $files = $1;
 585         @del = split(m/\s+/s, $files);
 586     }
 587
 588     if ($log =~ m/(?:\n|^)Modified-files:(.*?)(?=\n\w)/s ) {
 589         my $files = $1;
 590         @mod = split(m/\s+/s, $files);
 591     }
 592
 593     if ($log =~ m/(?:\n|^)Renamed-files:(.*?)(?=\n\w)/s ) {
 594         my $files = $1;
 595         @ren = split(m/\s+/s, $files);
 596     }
 597
 598     $sum ='';
 599     if ($log =~ m/^Summary:(.+?)$/m ) {
 600         $sum = $1;
 601         $sum =~ s/^\s+//;
 602         $sum =~ s/\s+$//;
 603     }
 604
 605     $msg = '';
 606     if ($log =~ m/\n\n(.+)$/s) {
 607         $msg = $1;
 608         $msg =~ s/^\s+//;
 609         $msg =~ s/\s+$//;
 610     }
 611
 612
 613     # cleanup the arrays
 614     foreach my $ref ( (\@add, \@del, \@mod, \@ren) ) {
 615         my @tmp = ();
 616         while (my $t = pop @$ref) {
 617             next unless length ($t);
 618             next if $t =~ m!\{arch\}/!;
 619             next if $t =~ m!\.arch-ids/!;
 620             next if $t =~ m!\.arch-inventory$!;
 621            # tla cat-archive-log will give us filenames with spaces as file\(sp)name - why?
 622            # we can assume that any filename with \ indicates some pika escaping that we want to get rid of.
 623            if  ($t =~ /\\/ ){
 624                $t = `tla escape --unescaped '$t'`;
 625            }
 626             push (@tmp, shell_quote($t));
 627         }
 628         @$ref = @tmp;
 629     }
 630
 631     #print Dumper [$sum, $msg, \@add, \@del, \@mod, \@ren];
 632     return       ($sum, $msg, \@add, \@del, \@mod, \@ren);
 633 }
 634
 635 # write/read a tag
 636 sub tag {
 637     my ($tag, $commit) = @_;
 638
 639     if ($opt_o) {
 640         $tag =~ s|/|--|g;
 641     } else {
 642         # don't use subdirs for tags yet, it could screw up other porcelains
 643         $tag =~ s|/|,|g;
 644     }
 645
 646     if ($commit) {
 647         open(C,">","$git_dir/refs/tags/$tag")
 648             or die "Cannot create tag $tag: $!\n";
 649         print C "$commit\n"
 650             or die "Cannot write tag $tag: $!\n";
 651         close(C)
 652             or die "Cannot write tag $tag: $!\n";
 653         print " * Created tag '$tag' on '$commit'\n" if $opt_v;
 654     } else {                    # read
 655         open(C,"<","$git_dir/refs/tags/$tag")
 656             or die "Cannot read tag $tag: $!\n";
 657         $commit = <C>;
 658         chomp $commit;
 659         die "Error reading tag $tag: $!\n" unless length $commit == 40;
 660         close(C)
 661             or die "Cannot read tag $tag: $!\n";
 662         return $commit;
 663     }
 664 }
 665
 666 # write/read a private tag
 667 # reads fail softly if the tag isn't there
 668 sub ptag {
 669     my ($tag, $commit) = @_;
 670
 671     # don't use subdirs for tags yet, it could screw up other porcelains
 672     $tag =~ s|/|,|g;
 673
 674     my $tag_file = "$ptag_dir/$tag";
 675     my $tag_branch_dir = dirname($tag_file);
 676     mkpath($tag_branch_dir) unless (-d $tag_branch_dir);
 677
 678     if ($commit) {              # write
 679         open(C,">",$tag_file)
 680             or die "Cannot create tag $tag: $!\n";
 681         print C "$commit\n"
 682             or die "Cannot write tag $tag: $!\n";
 683         close(C)
 684             or die "Cannot write tag $tag: $!\n";
 685         $rptags{$commit} = $tag
 686             unless $tag =~ m/--base-0$/;
 687     } else {                    # read
 688         # if the tag isn't there, return 0
 689         unless ( -s $tag_file) {
 690             return 0;
 691         }
 692         open(C,"<",$tag_file)
 693             or die "Cannot read tag $tag: $!\n";
 694         $commit = <C>;
 695         chomp $commit;
 696         die "Error reading tag $tag: $!\n" unless length $commit == 40;
 697         close(C)
 698             or die "Cannot read tag $tag: $!\n";
 699         unless (defined $rptags{$commit}) {
 700             $rptags{$commit} = $tag;
 701         }
 702         return $commit;
 703     }
 704 }
 705
 706 sub find_parents {
 707     #
 708     # Identify what branches are merging into me
 709     # and whether we are fully merged
 710     # git-merge-base <headsha> <headsha> should tell
 711     # me what the base of the merge should be
 712     #
 713     my $ps = shift;
 714
 715     my %branches; # holds an arrayref per branch
 716                   # the arrayref contains a list of
 717                   # merged patches between the base
 718                   # of the merge and the current head
 719
 720     my @parents;  # parents found for this commit
 721
 722     # simple loop to split the merges
 723     # per branch
 724     foreach my $merge (@{$ps->{merges}}) {
 725         my $branch = git_branchname($merge);
 726         unless (defined $branches{$branch} ){
 727             $branches{$branch} = [];
 728         }
 729         push @{$branches{$branch}}, $merge;
 730     }
 731
 732     #
 733     # foreach branch find a merge base and walk it to the
 734     # head where we are, collecting the merged patchsets that
 735     # Arch has recorded. Keep that in @have
 736     # Compare that with the commits on the other branch
 737     # between merge-base and the tip of the branch (@need)
 738     # and see if we have a series of consecutive patches
 739     # starting from the merge base. The tip of the series
 740     # of consecutive patches merged is our new parent for
 741     # that branch.
 742     #
 743     foreach my $branch (keys %branches) {
 744
 745         # check that we actually know about the branch
 746         next unless -e "$git_dir/refs/heads/$branch";
 747
 748         my $mergebase = `git-merge-base $branch $ps->{branch}`;
 749         if ($?) {
 750             # Don't die here, Arch supports one-way cherry-picking
 751             # between branches with no common base (or any relationship
 752             # at all beforehand)
 753             warn "Cannot find merge base for $branch and $ps->{branch}";
 754             next;
 755         }
 756         chomp $mergebase;
 757
 758         # now walk up to the mergepoint collecting what patches we have
 759         my $branchtip = git_rev_parse($ps->{branch});
 760         my @ancestors = `git-rev-list --merge-order $branchtip ^$mergebase`;
 761         my %have; # collected merges this branch has
 762         foreach my $merge (@{$ps->{merges}}) {
 763             $have{$merge} = 1;
 764         }
 765         my %ancestorshave;
 766         foreach my $par (@ancestors) {
 767             $par = commitid2pset($par);
 768             if (defined $par->{merges}) {
 769                 foreach my $merge (@{$par->{merges}}) {
 770                     $ancestorshave{$merge}=1;
 771                 }
 772             }
 773         }
 774         # print "++++ Merges in $ps->{id} are....\n";
 775         # my @have = sort keys %have;   print Dumper(\@have);
 776
 777         # merge what we have with what ancestors have
 778         %have = (%have, %ancestorshave);
 779
 780         # see what the remote branch has - these are the merges we
 781         # will want to have in a consecutive series from the mergebase
 782         my $otherbranchtip = git_rev_parse($branch);
 783         my @needraw = `git-rev-list --merge-order $otherbranchtip ^$mergebase`;
 784         my @need;
 785         foreach my $needps (@needraw) {         # get the psets
 786             $needps = commitid2pset($needps);
 787             # git-rev-list will also
 788             # list commits merged in via earlier
 789             # merges. we are only interested in commits
 790             # from the branch we're looking at
 791             if ($branch eq $needps->{branch}) {
 792                 push @need, $needps->{id};
 793             }
 794         }
 795
 796         # print "++++ Merges from $branch we want are....\n";
 797         # print Dumper(\@need);
 798
 799         my $newparent;
 800         while (my $needed_commit = pop @need) {
 801             if ($have{$needed_commit}) {
 802                 $newparent = $needed_commit;
 803             } else {
 804                 last; # break out of the while
 805             }
 806         }
 807         if ($newparent) {
 808             push @parents, $newparent;
 809         }
 810
 811
 812     } # end foreach branch
 813
 814     # prune redundant parents
 815     my %parents;
 816     foreach my $p (@parents) {
 817         $parents{$p} = 1;
 818     }
 819     foreach my $p (@parents) {
 820         next unless exists $psets{$p}{merges};
 821         next unless ref    $psets{$p}{merges};
 822         my @merges = @{$psets{$p}{merges}};
 823         foreach my $merge (@merges) {
 824             if ($parents{$merge}) {
 825                 delete $parents{$merge};
 826             }
 827         }
 828     }
 829     @parents = keys %parents;
 830     @parents = map { " -p " . ptag($_) } @parents;
 831     return @parents;
 832 }
 833
 834 sub git_rev_parse {
 835     my $name = shift;
 836     my $val  = `git-rev-parse $name`;
 837     die "Error: git-rev-parse $name" if $?;
 838     chomp $val;
 839     return $val;
 840 }
 841
 842 # resolve a SHA1 to a known patchset
 843 sub commitid2pset {
 844     my $commitid = shift;
 845     chomp $commitid;
 846     my $name = $rptags{$commitid}
 847         || die "Cannot find reverse tag mapping for $commitid";
 848     $name =~ s|,|/|;
 849     my $ps   = $psets{$name}
 850         || (print Dumper(sort keys %psets)) && die "Cannot find patchset for $name";
 851     return $ps;
 852 }