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  - sort and apply patches by graphing ancestry relations instead of just
  29    relying in dates supplied in the changeset itself.
  30    tla ancestry-graph -m could be helpful here...
  31
  32 =head1 Devel tricks
  33
  34 Add print in front of the shell commands invoked via backticks.
  35
  36 =head1 Devel Notes
  37
  38 There are several places where Arch and git terminology are intermixed
  39 and potentially confused.
  40
  41 The notion of a "branch" in git is approximately equivalent to
  42 a "archive/category--branch--version" in Arch.  Also, it should be noted
  43 that the "--branch" portion of "archive/category--branch--version" is really
  44 optional in Arch although not many people (nor tools!) seem to know this.
  45 This means that "archive/category--version" is also a valid "branch"
  46 in git terms.
  47
  48 We always refer to Arch names by their fully qualified variant (which
  49 means the "archive" name is prefixed.
  50
  51 For people unfamiliar with Arch, an "archive" is the term for "repository",
  52 and can contain multiple, unrelated branches.
  53
  54 =cut
  55
  56 use strict;
  57 use warnings;
  58 use Getopt::Std;
  59 use File::Temp qw(tempdir);
  60 use File::Path qw(mkpath rmtree);
  61 use File::Basename qw(basename dirname);
  62 use Data::Dumper qw/ Dumper /;
  63 use IPC::Open2;
  64
  65 $SIG{'PIPE'}="IGNORE";
  66 $ENV{'TZ'}="UTC";
  67
  68 my $git_dir = $ENV{"GIT_DIR"} || ".git";
  69 $ENV{"GIT_DIR"} = $git_dir;
  70 my $ptag_dir = "$git_dir/archimport/tags";
  71
  72 our($opt_h,$opt_f,$opt_v,$opt_T,$opt_t,$opt_D,$opt_a,$opt_o);
  73
  74 sub usage() {
  75     print STDERR <<END;
  76 Usage: ${\basename $0}     # fetch/update GIT from Arch
  77        [ -f ] [ -o ] [ -h ] [ -v ] [ -T ] [ -a ] [ -D depth  ] [ -t tempdir ]
  78        repository/arch-branch [ repository/arch-branch] ...
  79 END
  80     exit(1);
  81 }
  82
  83 getopts("fThvat:D:") or usage();
  84 usage if $opt_h;
  85
  86 @ARGV >= 1 or usage();
  87 # $arch_branches:
  88 # values associated with keys:
  89 #   =1 - Arch version / git 'branch' detected via abrowse on a limit
  90 #   >1 - Arch version / git 'branch' of an auxilliary branch we've merged
  91 my %arch_branches = map { $_ => 1 } @ARGV;
  92
  93 $ENV{'TMPDIR'} = $opt_t if $opt_t; # $ENV{TMPDIR} will affect tempdir() calls:
  94 my $tmp = tempdir('git-archimport-XXXXXX', TMPDIR => 1, CLEANUP => 1);
  95 $opt_v && print "+ Using $tmp as temporary directory\n";
  96
  97 my %reachable = ();             # Arch repositories we can access
  98 my %unreachable = ();           # Arch repositories we can't access :<
  99 my @psets  = ();                # the collection
 100 my %psets  = ();                # the collection, by name
 101 my %stats  = (                  # Track which strategy we used to import:
 102         get_tag => 0, replay => 0, get_new => 0, get_delta => 0,
 103         simple_changeset => 0, import_or_tag => 0
 104 );
 105
 106 my %rptags = ();                # my reverse private tags
 107                                 # to map a SHA1 to a commitid
 108 my $TLA = $ENV{'ARCH_CLIENT'} || 'tla';
 109
 110 sub do_abrowse {
 111     my $stage = shift;
 112     while (my ($limit, $level) = each %arch_branches) {
 113         next unless $level == $stage;
 114
 115         open ABROWSE, "$TLA abrowse -fkD --merges $limit |"
 116                                 or die "Problems with tla abrowse: $!";
 117
 118         my %ps        = ();         # the current one
 119         my $lastseen  = '';
 120
 121         while (<ABROWSE>) {
 122             chomp;
 123
 124             # first record padded w 8 spaces
 125             if (s/^\s{8}\b//) {
 126                 my ($id, $type) = split(m/\s+/, $_, 2);
 127
 128                 my %last_ps;
 129                 # store the record we just captured
 130                 if (%ps && !exists $psets{ $ps{id} }) {
 131                     %last_ps = %ps; # break references
 132                     push (@psets, \%last_ps);
 133                     $psets{ $last_ps{id} } = \%last_ps;
 134                 }
 135
 136                 my $branch = extract_versionname($id);
 137                 %ps = ( id => $id, branch => $branch );
 138                 if (%last_ps && ($last_ps{branch} eq $branch)) {
 139                     $ps{parent_id} = $last_ps{id};
 140                 }
 141
 142                 $arch_branches{$branch} = 1;
 143                 $lastseen = 'id';
 144
 145                 # deal with types (should work with baz or tla):
 146                 if ($type =~ m/\(.*changeset\)/) {
 147                     $ps{type} = 's';
 148                 } elsif ($type =~ /\(.*import\)/) {
 149                     $ps{type} = 'i';
 150                 } elsif ($type =~ m/\(tag.*?(\S+\@\S+).*?\)/) {
 151                     $ps{type} = 't';
 152                     # read which revision we've tagged when we parse the log
 153                     $ps{tag}  = $1;
 154                 } else {
 155                     warn "Unknown type $type";
 156                 }
 157
 158                 $arch_branches{$branch} = 1;
 159                 $lastseen = 'id';
 160             } elsif (s/^\s{10}//) {
 161                 # 10 leading spaces or more
 162                 # indicate commit metadata
 163
 164                 # date
 165                 if ($lastseen eq 'id' && m/^(\d{4}-\d\d-\d\d \d\d:\d\d:\d\d)/){
 166                     $ps{date}   = $1;
 167                     $lastseen = 'date';
 168                 } elsif ($_ eq 'merges in:') {
 169                     $ps{merges} = [];
 170                     $lastseen = 'merges';
 171                 } elsif ($lastseen eq 'merges' && s/^\s{2}//) {
 172                     my $id = $_;
 173                     push (@{$ps{merges}}, $id);
 174
 175                     # aggressive branch finding:
 176                     if ($opt_D) {
 177                         my $branch = extract_versionname($id);
 178                         my $repo = extract_reponame($branch);
 179
 180                         if (archive_reachable($repo) &&
 181                                 !defined $arch_branches{$branch}) {
 182                             $arch_branches{$branch} = $stage + 1;
 183                         }
 184                     }
 185                 } else {
 186                     warn "more metadata after merges!?: $_\n" unless /^\s*$/;
 187                 }
 188             }
 189         }
 190
 191         if (%ps && !exists $psets{ $ps{id} }) {
 192             my %temp = %ps;         # break references
 193             if (@psets && $psets[$#psets]{branch} eq $ps{branch}) {
 194                 $temp{parent_id} = $psets[$#psets]{id};
 195             }
 196             push (@psets, \%temp);
 197             $psets{ $temp{id} } = \%temp;
 198         }
 199
 200         close ABROWSE or die "$TLA abrowse failed on $limit\n";
 201     }
 202 }                               # end foreach $root
 203
 204 do_abrowse(1);
 205 my $depth = 2;
 206 $opt_D ||= 0;
 207 while ($depth <= $opt_D) {
 208     do_abrowse($depth);
 209     $depth++;
 210 }
 211
 212 ## Order patches by time
 213 # FIXME see if we can find a more optimal way to do this by graphing
 214 # the ancestry data and walking it, that way we won't have to rely on
 215 # client-supplied dates
 216 @psets = sort {$a->{date}.$b->{id} cmp $b->{date}.$b->{id}} @psets;
 217
 218 #print Dumper \@psets;
 219
 220 ##
 221 ## TODO cleanup irrelevant patches
 222 ##      and put an initial import
 223 ##      or a full tag
 224 my $import = 0;
 225 unless (-d $git_dir) { # initial import
 226     if ($psets[0]{type} eq 'i' || $psets[0]{type} eq 't') {
 227         print "Starting import from $psets[0]{id}\n";
 228         `git-init-db`;
 229         die $! if $?;
 230         $import = 1;
 231     } else {
 232         die "Need to start from an import or a tag -- cannot use $psets[0]{id}";
 233     }
 234 } else {    # progressing an import
 235     # load the rptags
 236     opendir(DIR, $ptag_dir)
 237         || die "can't opendir: $!";
 238     while (my $file = readdir(DIR)) {
 239         # skip non-interesting-files
 240         next unless -f "$ptag_dir/$file";
 241
 242         # convert first '--' to '/' from old git-archimport to use
 243         # as an archivename/c--b--v private tag
 244         if ($file !~ m!,!) {
 245             my $oldfile = $file;
 246             $file =~ s!--!,!;
 247             print STDERR "converting old tag $oldfile to $file\n";
 248             rename("$ptag_dir/$oldfile", "$ptag_dir/$file") or die $!;
 249         }
 250         my $sha = ptag($file);
 251         chomp $sha;
 252         $rptags{$sha} = $file;
 253     }
 254     closedir DIR;
 255 }
 256
 257 # process patchsets
 258 # extract the Arch repository name (Arch "archive" in Arch-speak)
 259 sub extract_reponame {
 260     my $fq_cvbr = shift; # archivename/[[[[category]branch]version]revision]
 261     return (split(/\//, $fq_cvbr))[0];
 262 }
 263
 264 sub extract_versionname {
 265     my $name = shift;
 266     $name =~ s/--(?:patch|version(?:fix)?|base)-\d+$//;
 267     return $name;
 268 }
 269
 270 # convert a fully-qualified revision or version to a unique dirname:
 271 #   normalperson@yhbt.net-05/mpd--uclinux--1--patch-2
 272 # becomes: normalperson@yhbt.net-05,mpd--uclinux--1
 273 #
 274 # the git notion of a branch is closer to
 275 # archive/category--branch--version than archive/category--branch, so we
 276 # use this to convert to git branch names.
 277 # Also, keep archive names but replace '/' with ',' since it won't require
 278 # subdirectories, and is safer than swapping '--' which could confuse
 279 # reverse-mapping when dealing with bastard branches that
 280 # are just archive/category--version  (no --branch)
 281 sub tree_dirname {
 282     my $revision = shift;
 283     my $name = extract_versionname($revision);
 284     $name =~ s#/#,#;
 285     return $name;
 286 }
 287
 288 # old versions of git-archimport just use the <category--branch> part:
 289 sub old_style_branchname {
 290     my $id = shift;
 291     my $ret = safe_pipe_capture($TLA,'parse-package-name','-p',$id);
 292     chomp $ret;
 293     return $ret;
 294 }
 295
 296 *git_branchname = $opt_o ? *old_style_branchname : *tree_dirname;
 297
 298 sub process_patchset_accurate {
 299     my $ps = shift;
 300
 301     # switch to that branch if we're not already in that branch:
 302     if (-e "$git_dir/refs/heads/$ps->{branch}") {
 303        system('git-checkout','-f',$ps->{branch}) == 0 or die "$! $?\n";
 304
 305        # remove any old stuff that got leftover:
 306        my $rm = safe_pipe_capture('git-ls-files','--others','-z');
 307        rmtree(split(/\0/,$rm)) if $rm;
 308     }
 309
 310     # Apply the import/changeset/merge into the working tree
 311     my $dir = sync_to_ps($ps);
 312     # read the new log entry:
 313     my @commitlog = safe_pipe_capture($TLA,'cat-log','-d',$dir,$ps->{id});
 314     die "Error in cat-log: $!" if $?;
 315     chomp @commitlog;
 316
 317     # grab variables we want from the log, new fields get added to $ps:
 318     # (author, date, email, summary, message body ...)
 319     parselog($ps, \@commitlog);
 320
 321     if ($ps->{id} =~ /--base-0$/ && $ps->{id} ne $psets[0]{id}) {
 322         # this should work when importing continuations
 323         if ($ps->{tag} && (my $branchpoint = eval { ptag($ps->{tag}) })) {
 324
 325             # find where we are supposed to branch from
 326             system('git-checkout','-f','-b',$ps->{branch},
 327                             $branchpoint) == 0 or die "$! $?\n";
 328
 329             # remove any old stuff that got leftover:
 330             my $rm = safe_pipe_capture('git-ls-files','--others','-z');
 331             rmtree(split(/\0/,$rm)) if $rm;
 332
 333             # If we trust Arch with the fact that this is just
 334             # a tag, and it does not affect the state of the tree
 335             # then we just tag and move on
 336             tag($ps->{id}, $branchpoint);
 337             ptag($ps->{id}, $branchpoint);
 338             print " * Tagged $ps->{id} at $branchpoint\n";
 339             return 0;
 340         } else {
 341             warn "Tagging from unknown id unsupported\n" if $ps->{tag};
 342         }
 343         # allow multiple bases/imports here since Arch supports cherry-picks
 344         # from unrelated trees
 345     }
 346
 347     # update the index with all the changes we got
 348     system('git-ls-files --others -z | '.
 349             'git-update-index --add -z --stdin') == 0 or die "$! $?\n";
 350     system('git-ls-files --deleted -z | '.
 351             'git-update-index --remove -z --stdin') == 0 or die "$! $?\n";
 352     system('git-ls-files -z | '.
 353              'git-update-index -z --stdin') == 0 or die "$! $?\n";
 354     return 1;
 355 }
 356
 357 # the native changeset processing strategy.  This is very fast, but
 358 # does not handle permissions or any renames involving directories
 359 sub process_patchset_fast {
 360     my $ps = shift;
 361     #
 362     # create the branch if needed
 363     #
 364     if ($ps->{type} eq 'i' && !$import) {
 365         die "Should not have more than one 'Initial import' per GIT import: $ps->{id}";
 366     }
 367
 368     unless ($import) { # skip for import
 369         if ( -e "$git_dir/refs/heads/$ps->{branch}") {
 370             # we know about this branch
 371             system('git-checkout',$ps->{branch});
 372         } else {
 373             # new branch! we need to verify a few things
 374             die "Branch on a non-tag!" unless $ps->{type} eq 't';
 375             my $branchpoint = ptag($ps->{tag});
 376             die "Tagging from unknown id unsupported: $ps->{tag}"
 377                 unless $branchpoint;
 378
 379             # find where we are supposed to branch from
 380             system('git-checkout','-b',$ps->{branch},$branchpoint);
 381
 382             # If we trust Arch with the fact that this is just
 383             # a tag, and it does not affect the state of the tree
 384             # then we just tag and move on
 385             tag($ps->{id}, $branchpoint);
 386             ptag($ps->{id}, $branchpoint);
 387             print " * Tagged $ps->{id} at $branchpoint\n";
 388             return 0;
 389         }
 390         die $! if $?;
 391     }
 392
 393     #
 394     # Apply the import/changeset/merge into the working tree
 395     #
 396     if ($ps->{type} eq 'i' || $ps->{type} eq 't') {
 397         apply_import($ps) or die $!;
 398         $stats{import_or_tag}++;
 399         $import=0;
 400     } elsif ($ps->{type} eq 's') {
 401         apply_cset($ps);
 402         $stats{simple_changeset}++;
 403     }
 404
 405     #
 406     # prepare update git's index, based on what arch knows
 407     # about the pset, resolve parents, etc
 408     #
 409
 410     my @commitlog = safe_pipe_capture($TLA,'cat-archive-log',$ps->{id});
 411     die "Error in cat-archive-log: $!" if $?;
 412
 413     parselog($ps,\@commitlog);
 414
 415     # imports don't give us good info
 416     # on added files. Shame on them
 417     if ($ps->{type} eq 'i' || $ps->{type} eq 't') {
 418         system('git-ls-files --others -z | '.
 419                 'git-update-index --add -z --stdin') == 0 or die "$! $?\n";
 420         system('git-ls-files --deleted -z | '.
 421                 'git-update-index --remove -z --stdin') == 0 or die "$! $?\n";
 422     }
 423
 424     # TODO: handle removed_directories and renamed_directories:
 425
 426     if (my $add = $ps->{new_files}) {
 427         while (@$add) {
 428             my @slice = splice(@$add, 0, 100);
 429             system('git-update-index','--add','--',@slice) == 0 or
 430                             die "Error in git-update-index --add: $! $?\n";
 431         }
 432     }
 433
 434     if (my $del = $ps->{removed_files}) {
 435         unlink @$del;
 436         while (@$del) {
 437             my @slice = splice(@$del, 0, 100);
 438             system('git-update-index','--remove','--',@slice) == 0 or
 439                             die "Error in git-update-index --remove: $! $?\n";
 440         }
 441     }
 442
 443     if (my $ren = $ps->{renamed_files}) {                # renamed
 444         if (@$ren % 2) {
 445             die "Odd number of entries in rename!?";
 446         }
 447
 448         while (@$ren) {
 449             my $from = shift @$ren;
 450             my $to   = shift @$ren;
 451
 452             unless (-d dirname($to)) {
 453                 mkpath(dirname($to)); # will die on err
 454             }
 455             # print "moving $from $to";
 456             rename($from, $to) or die "Error renaming '$from' '$to': $!\n";
 457             system('git-update-index','--remove','--',$from) == 0 or
 458                             die "Error in git-update-index --remove: $! $?\n";
 459             system('git-update-index','--add','--',$to) == 0 or
 460                             die "Error in git-update-index --add: $! $?\n";
 461         }
 462     }
 463
 464     if (my $mod = $ps->{modified_files}) {
 465         while (@$mod) {
 466             my @slice = splice(@$mod, 0, 100);
 467             system('git-update-index','--',@slice) == 0 or
 468                             die "Error in git-update-index: $! $?\n";
 469         }
 470     }
 471     return 1; # we successfully applied the changeset
 472 }
 473
 474 if ($opt_f) {
 475     print "Will import patchsets using the fast strategy\n",
 476             "Renamed directories and permission changes will be missed\n";
 477     *process_patchset = *process_patchset_fast;
 478 } else {
 479     print "Using the default (accurate) import strategy.\n",
 480             "Things may be a bit slow\n";
 481     *process_patchset = *process_patchset_accurate;
 482 }
 483
 484 foreach my $ps (@psets) {
 485     # process patchsets
 486     $ps->{branch} = git_branchname($ps->{id});
 487
 488     #
 489     # ensure we have a clean state
 490     #
 491     if (my $dirty = `git-diff-files`) {
 492         die "Unclean tree when about to process $ps->{id} " .
 493             " - did we fail to commit cleanly before?\n$dirty";
 494     }
 495     die $! if $?;
 496
 497     #
 498     # skip commits already in repo
 499     #
 500     if (ptag($ps->{id})) {
 501       $opt_v && print " * Skipping already imported: $ps->{id}\n";
 502       next;
 503     }
 504
 505     print " * Starting to work on $ps->{id}\n";
 506
 507     process_patchset($ps) or next;
 508
 509     # warn "errors when running git-update-index! $!";
 510     my $tree = `git-write-tree`;
 511     die "cannot write tree $!" if $?;
 512     chomp $tree;
 513
 514     #
 515     # Who's your daddy?
 516     #
 517     my @par;
 518     if ( -e "$git_dir/refs/heads/$ps->{branch}") {
 519         if (open HEAD, "<","$git_dir/refs/heads/$ps->{branch}") {
 520             my $p = <HEAD>;
 521             close HEAD;
 522             chomp $p;
 523             push @par, '-p', $p;
 524         } else {
 525             if ($ps->{type} eq 's') {
 526                 warn "Could not find the right head for the branch $ps->{branch}";
 527             }
 528         }
 529     }
 530
 531     if ($ps->{merges}) {
 532         push @par, find_parents($ps);
 533     }
 534
 535     #
 536     # Commit, tag and clean state
 537     #
 538     $ENV{TZ}                  = 'GMT';
 539     $ENV{GIT_AUTHOR_NAME}     = $ps->{author};
 540     $ENV{GIT_AUTHOR_EMAIL}    = $ps->{email};
 541     $ENV{GIT_AUTHOR_DATE}     = $ps->{date};
 542     $ENV{GIT_COMMITTER_NAME}  = $ps->{author};
 543     $ENV{GIT_COMMITTER_EMAIL} = $ps->{email};
 544     $ENV{GIT_COMMITTER_DATE}  = $ps->{date};
 545
 546     my $pid = open2(*READER, *WRITER,'git-commit-tree',$tree,@par)
 547         or die $!;
 548     print WRITER $ps->{summary},"\n";
 549     print WRITER $ps->{message},"\n";
 550
 551     # make it easy to backtrack and figure out which Arch revision this was:
 552     print WRITER 'git-archimport-id: ',$ps->{id},"\n";
 553
 554     close WRITER;
 555     my $commitid = <READER>;    # read
 556     chomp $commitid;
 557     close READER;
 558     waitpid $pid,0;             # close;
 559
 560     if (length $commitid != 40) {
 561         die "Something went wrong with the commit! $! $commitid";
 562     }
 563     #
 564     # Update the branch
 565     #
 566     open  HEAD, ">","$git_dir/refs/heads/$ps->{branch}";
 567     print HEAD $commitid;
 568     close HEAD;
 569     system('git-update-ref', 'HEAD', "$ps->{branch}");
 570
 571     # tag accordingly
 572     ptag($ps->{id}, $commitid); # private tag
 573     if ($opt_T || $ps->{type} eq 't' || $ps->{type} eq 'i') {
 574         tag($ps->{id}, $commitid);
 575     }
 576     print " * Committed $ps->{id}\n";
 577     print "   + tree   $tree\n";
 578     print "   + commit $commitid\n";
 579     $opt_v && print "   + commit date is  $ps->{date} \n";
 580     $opt_v && print "   + parents:  ",join(' ',@par),"\n";
 581 }
 582
 583 if ($opt_v) {
 584     foreach (sort keys %stats) {
 585         print" $_: $stats{$_}\n";
 586     }
 587 }
 588 exit 0;
 589
 590 # used by the accurate strategy:
 591 sub sync_to_ps {
 592     my $ps = shift;
 593     my $tree_dir = $tmp.'/'.tree_dirname($ps->{id});
 594
 595     $opt_v && print "sync_to_ps($ps->{id}) method: ";
 596
 597     if (-d $tree_dir) {
 598         if ($ps->{type} eq 't') {
 599             $opt_v && print "get (tag)\n";
 600             # looks like a tag-only or (worse,) a mixed tags/changeset branch,
 601             # can't rely on replay to work correctly on these
 602             rmtree($tree_dir);
 603             safe_pipe_capture($TLA,'get','--no-pristine',$ps->{id},$tree_dir);
 604             $stats{get_tag}++;
 605         } else {
 606                 my $tree_id = arch_tree_id($tree_dir);
 607                 if ($ps->{parent_id} && ($ps->{parent_id} eq $tree_id)) {
 608                     # the common case (hopefully)
 609                     $opt_v && print "replay\n";
 610                     safe_pipe_capture($TLA,'replay','-d',$tree_dir,$ps->{id});
 611                     $stats{replay}++;
 612                 } else {
 613                     # getting one tree is usually faster than getting two trees
 614                     # and applying the delta ...
 615                     rmtree($tree_dir);
 616                     $opt_v && print "apply-delta\n";
 617                     safe_pipe_capture($TLA,'get','--no-pristine',
 618                                         $ps->{id},$tree_dir);
 619                     $stats{get_delta}++;
 620                 }
 621         }
 622     } else {
 623         # new branch work
 624         $opt_v && print "get (new tree)\n";
 625         safe_pipe_capture($TLA,'get','--no-pristine',$ps->{id},$tree_dir);
 626         $stats{get_new}++;
 627     }
 628
 629     # added -I flag to rsync since we're going to fast! AIEEEEE!!!!
 630     system('rsync','-aI','--delete','--exclude',$git_dir,
 631 #               '--exclude','.arch-inventory',
 632                 '--exclude','.arch-ids','--exclude','{arch}',
 633                 '--exclude','+*','--exclude',',*',
 634                 "$tree_dir/",'./') == 0 or die "Cannot rsync $tree_dir: $! $?";
 635     return $tree_dir;
 636 }
 637
 638 sub apply_import {
 639     my $ps = shift;
 640     my $bname = git_branchname($ps->{id});
 641
 642     mkpath($tmp);
 643
 644     safe_pipe_capture($TLA,'get','-s','--no-pristine',$ps->{id},"$tmp/import");
 645     die "Cannot get import: $!" if $?;
 646     system('rsync','-aI','--delete', '--exclude',$git_dir,
 647                 '--exclude','.arch-ids','--exclude','{arch}',
 648                 "$tmp/import/", './');
 649     die "Cannot rsync import:$!" if $?;
 650
 651     rmtree("$tmp/import");
 652     die "Cannot remove tempdir: $!" if $?;
 653
 654
 655     return 1;
 656 }
 657
 658 sub apply_cset {
 659     my $ps = shift;
 660
 661     mkpath($tmp);
 662
 663     # get the changeset
 664     safe_pipe_capture($TLA,'get-changeset',$ps->{id},"$tmp/changeset");
 665     die "Cannot get changeset: $!" if $?;
 666
 667     # apply patches
 668     if (`find $tmp/changeset/patches -type f -name '*.patch'`) {
 669         # this can be sped up considerably by doing
 670         #    (find | xargs cat) | patch
 671         # but that cna get mucked up by patches
 672         # with missing trailing newlines or the standard
 673         # 'missing newline' flag in the patch - possibly
 674         # produced with an old/buggy diff.
 675         # slow and safe, we invoke patch once per patchfile
 676         `find $tmp/changeset/patches -type f -name '*.patch' -print0 | grep -zv '{arch}' | xargs -iFILE -0 --no-run-if-empty patch -p1 --forward -iFILE`;
 677         die "Problem applying patches! $!" if $?;
 678     }
 679
 680     # apply changed binary files
 681     if (my @modified = `find $tmp/changeset/patches -type f -name '*.modified'`) {
 682         foreach my $mod (@modified) {
 683             chomp $mod;
 684             my $orig = $mod;
 685             $orig =~ s/\.modified$//; # lazy
 686             $orig =~ s!^\Q$tmp\E/changeset/patches/!!;
 687             #print "rsync -p '$mod' '$orig'";
 688             system('rsync','-p',$mod,"./$orig");
 689             die "Problem applying binary changes! $!" if $?;
 690         }
 691     }
 692
 693     # bring in new files
 694     system('rsync','-aI','--exclude',$git_dir,
 695                 '--exclude','.arch-ids',
 696                 '--exclude', '{arch}',
 697                 "$tmp/changeset/new-files-archive/",'./');
 698
 699     # deleted files are hinted from the commitlog processing
 700
 701     rmtree("$tmp/changeset");
 702 }
 703
 704
 705 # =for reference
 706 # notes: *-files/-directories keys cannot have spaces, they're always
 707 # pika-escaped.  Everything after the first newline
 708 # A log entry looks like:
 709 # Revision: moodle-org--moodle--1.3.3--patch-15
 710 # Archive: arch-eduforge@catalyst.net.nz--2004
 711 # Creator: Penny Leach <penny@catalyst.net.nz>
 712 # Date: Wed May 25 14:15:34 NZST 2005
 713 # Standard-date: 2005-05-25 02:15:34 GMT
 714 # New-files: lang/de/.arch-ids/block_glossary_random.php.id
 715 #     lang/de/.arch-ids/block_html.php.id
 716 # New-directories: lang/de/help/questionnaire
 717 #     lang/de/help/questionnaire/.arch-ids
 718 # Renamed-files: .arch-ids/db_sears.sql.id db/.arch-ids/db_sears.sql.id
 719 #    db_sears.sql db/db_sears.sql
 720 # Removed-files: lang/be/docs/.arch-ids/release.html.id
 721 #     lang/be/docs/.arch-ids/releaseold.html.id
 722 # Modified-files: admin/cron.php admin/delete.php
 723 #     admin/editor.html backup/lib.php backup/restore.php
 724 # New-patches: arch-eduforge@catalyst.net.nz--2004/moodle-org--moodle--1.3.3--patch-15
 725 # Summary: Updating to latest from MOODLE_14_STABLE (1.4.5+)
 726 #   summary can be multiline with a leading space just like the above fields
 727 # Keywords:
 728 #
 729 # Updating yadda tadda tadda madda
 730 sub parselog {
 731     my ($ps, $log) = @_;
 732     my $key = undef;
 733
 734     # headers we want that contain filenames:
 735     my %want_headers = (
 736         new_files => 1,
 737         modified_files => 1,
 738         renamed_files => 1,
 739         renamed_directories => 1,
 740         removed_files => 1,
 741         removed_directories => 1,
 742     );
 743
 744     chomp (@$log);
 745     while ($_ = shift @$log) {
 746         if (/^Continuation-of:\s*(.*)/) {
 747             $ps->{tag} = $1;
 748             $key = undef;
 749         } elsif (/^Summary:\s*(.*)$/ ) {
 750             # summary can be multiline as long as it has a leading space
 751             $ps->{summary} = [ $1 ];
 752             $key = 'summary';
 753         } elsif (/^Creator: (.*)\s*<([^\>]+)>/) {
 754             $ps->{author} = $1;
 755             $ps->{email} = $2;
 756             $key = undef;
 757         # any *-files or *-directories can be read here:
 758         } elsif (/^([A-Z][a-z\-]+):\s*(.*)$/) {
 759             my $val = $2;
 760             $key = lc $1;
 761             $key =~ tr/-/_/; # too lazy to quote :P
 762             if ($want_headers{$key}) {
 763                 push @{$ps->{$key}}, split(/\s+/, $val);
 764             } else {
 765                 $key = undef;
 766             }
 767         } elsif (/^$/) {
 768             last; # remainder of @$log that didn't get shifted off is message
 769         } elsif ($key) {
 770             if (/^\s+(.*)$/) {
 771                 if ($key eq 'summary') {
 772                     push @{$ps->{$key}}, $1;
 773                 } else { # files/directories:
 774                     push @{$ps->{$key}}, split(/\s+/, $1);
 775                 }
 776             } else {
 777                 $key = undef;
 778             }
 779         }
 780     }
 781
 782     # post-processing:
 783     $ps->{summary} = join("\n",@{$ps->{summary}})."\n";
 784     $ps->{message} = join("\n",@$log);
 785
 786     # skip Arch control files, unescape pika-escaped files
 787     foreach my $k (keys %want_headers) {
 788         next unless (defined $ps->{$k});
 789         my @tmp = ();
 790         foreach my $t (@{$ps->{$k}}) {
 791            next unless length ($t);
 792            next if $t =~ m!\{arch\}/!;
 793            next if $t =~ m!\.arch-ids/!;
 794            # should we skip this?
 795            next if $t =~ m!\.arch-inventory$!;
 796            # tla cat-archive-log will give us filenames with spaces as file\(sp)name - why?
 797            # we can assume that any filename with \ indicates some pika escaping that we want to get rid of.
 798            if ($t =~ /\\/ ){
 799                $t = (safe_pipe_capture($TLA,'escape','--unescaped',$t))[0];
 800            }
 801            push @tmp, $t;
 802         }
 803         $ps->{$k} = \@tmp;
 804     }
 805 }
 806
 807 # write/read a tag
 808 sub tag {
 809     my ($tag, $commit) = @_;
 810
 811     if ($opt_o) {
 812         $tag =~ s|/|--|g;
 813     } else {
 814         # don't use subdirs for tags yet, it could screw up other porcelains
 815         $tag =~ s|/|,|g;
 816     }
 817
 818     if ($commit) {
 819         open(C,">","$git_dir/refs/tags/$tag")
 820             or die "Cannot create tag $tag: $!\n";
 821         print C "$commit\n"
 822             or die "Cannot write tag $tag: $!\n";
 823         close(C)
 824             or die "Cannot write tag $tag: $!\n";
 825         print " * Created tag '$tag' on '$commit'\n" if $opt_v;
 826     } else {                    # read
 827         open(C,"<","$git_dir/refs/tags/$tag")
 828             or die "Cannot read tag $tag: $!\n";
 829         $commit = <C>;
 830         chomp $commit;
 831         die "Error reading tag $tag: $!\n" unless length $commit == 40;
 832         close(C)
 833             or die "Cannot read tag $tag: $!\n";
 834         return $commit;
 835     }
 836 }
 837
 838 # write/read a private tag
 839 # reads fail softly if the tag isn't there
 840 sub ptag {
 841     my ($tag, $commit) = @_;
 842
 843     # don't use subdirs for tags yet, it could screw up other porcelains
 844     $tag =~ s|/|,|g;
 845
 846     my $tag_file = "$ptag_dir/$tag";
 847     my $tag_branch_dir = dirname($tag_file);
 848     mkpath($tag_branch_dir) unless (-d $tag_branch_dir);
 849
 850     if ($commit) {              # write
 851         open(C,">",$tag_file)
 852             or die "Cannot create tag $tag: $!\n";
 853         print C "$commit\n"
 854             or die "Cannot write tag $tag: $!\n";
 855         close(C)
 856             or die "Cannot write tag $tag: $!\n";
 857         $rptags{$commit} = $tag
 858             unless $tag =~ m/--base-0$/;
 859     } else {                    # read
 860         # if the tag isn't there, return 0
 861         unless ( -s $tag_file) {
 862             return 0;
 863         }
 864         open(C,"<",$tag_file)
 865             or die "Cannot read tag $tag: $!\n";
 866         $commit = <C>;
 867         chomp $commit;
 868         die "Error reading tag $tag: $!\n" unless length $commit == 40;
 869         close(C)
 870             or die "Cannot read tag $tag: $!\n";
 871         unless (defined $rptags{$commit}) {
 872             $rptags{$commit} = $tag;
 873         }
 874         return $commit;
 875     }
 876 }
 877
 878 sub find_parents {
 879     #
 880     # Identify what branches are merging into me
 881     # and whether we are fully merged
 882     # git-merge-base <headsha> <headsha> should tell
 883     # me what the base of the merge should be
 884     #
 885     my $ps = shift;
 886
 887     my %branches; # holds an arrayref per branch
 888                   # the arrayref contains a list of
 889                   # merged patches between the base
 890                   # of the merge and the current head
 891
 892     my @parents;  # parents found for this commit
 893
 894     # simple loop to split the merges
 895     # per branch
 896     foreach my $merge (@{$ps->{merges}}) {
 897         my $branch = git_branchname($merge);
 898         unless (defined $branches{$branch} ){
 899             $branches{$branch} = [];
 900         }
 901         push @{$branches{$branch}}, $merge;
 902     }
 903
 904     #
 905     # foreach branch find a merge base and walk it to the
 906     # head where we are, collecting the merged patchsets that
 907     # Arch has recorded. Keep that in @have
 908     # Compare that with the commits on the other branch
 909     # between merge-base and the tip of the branch (@need)
 910     # and see if we have a series of consecutive patches
 911     # starting from the merge base. The tip of the series
 912     # of consecutive patches merged is our new parent for
 913     # that branch.
 914     #
 915     foreach my $branch (keys %branches) {
 916
 917         # check that we actually know about the branch
 918         next unless -e "$git_dir/refs/heads/$branch";
 919
 920         my $mergebase = `git-merge-base $branch $ps->{branch}`;
 921         if ($?) {
 922             # Don't die here, Arch supports one-way cherry-picking
 923             # between branches with no common base (or any relationship
 924             # at all beforehand)
 925             warn "Cannot find merge base for $branch and $ps->{branch}";
 926             next;
 927         }
 928         chomp $mergebase;
 929
 930         # now walk up to the mergepoint collecting what patches we have
 931         my $branchtip = git_rev_parse($ps->{branch});
 932         my @ancestors = `git-rev-list --merge-order $branchtip ^$mergebase`;
 933         my %have; # collected merges this branch has
 934         foreach my $merge (@{$ps->{merges}}) {
 935             $have{$merge} = 1;
 936         }
 937         my %ancestorshave;
 938         foreach my $par (@ancestors) {
 939             $par = commitid2pset($par);
 940             if (defined $par->{merges}) {
 941                 foreach my $merge (@{$par->{merges}}) {
 942                     $ancestorshave{$merge}=1;
 943                 }
 944             }
 945         }
 946         # print "++++ Merges in $ps->{id} are....\n";
 947         # my @have = sort keys %have;   print Dumper(\@have);
 948
 949         # merge what we have with what ancestors have
 950         %have = (%have, %ancestorshave);
 951
 952         # see what the remote branch has - these are the merges we
 953         # will want to have in a consecutive series from the mergebase
 954         my $otherbranchtip = git_rev_parse($branch);
 955         my @needraw = `git-rev-list --merge-order $otherbranchtip ^$mergebase`;
 956         my @need;
 957         foreach my $needps (@needraw) {         # get the psets
 958             $needps = commitid2pset($needps);
 959             # git-rev-list will also
 960             # list commits merged in via earlier
 961             # merges. we are only interested in commits
 962             # from the branch we're looking at
 963             if ($branch eq $needps->{branch}) {
 964                 push @need, $needps->{id};
 965             }
 966         }
 967
 968         # print "++++ Merges from $branch we want are....\n";
 969         # print Dumper(\@need);
 970
 971         my $newparent;
 972         while (my $needed_commit = pop @need) {
 973             if ($have{$needed_commit}) {
 974                 $newparent = $needed_commit;
 975             } else {
 976                 last; # break out of the while
 977             }
 978         }
 979         if ($newparent) {
 980             push @parents, $newparent;
 981         }
 982
 983
 984     } # end foreach branch
 985
 986     # prune redundant parents
 987     my %parents;
 988     foreach my $p (@parents) {
 989         $parents{$p} = 1;
 990     }
 991     foreach my $p (@parents) {
 992         next unless exists $psets{$p}{merges};
 993         next unless ref    $psets{$p}{merges};
 994         my @merges = @{$psets{$p}{merges}};
 995         foreach my $merge (@merges) {
 996             if ($parents{$merge}) {
 997                 delete $parents{$merge};
 998             }
 999         }
1000     }
1001
1002     @parents = ();
1003     foreach (keys %parents) {
1004         push @parents, '-p', ptag($_);
1005     }
1006     return @parents;
1007 }
1008
1009 sub git_rev_parse {
1010     my $name = shift;
1011     my $val  = `git-rev-parse $name`;
1012     die "Error: git-rev-parse $name" if $?;
1013     chomp $val;
1014     return $val;
1015 }
1016
1017 # resolve a SHA1 to a known patchset
1018 sub commitid2pset {
1019     my $commitid = shift;
1020     chomp $commitid;
1021     my $name = $rptags{$commitid}
1022         || die "Cannot find reverse tag mapping for $commitid";
1023     $name =~ s|,|/|;
1024     my $ps   = $psets{$name}
1025         || (print Dumper(sort keys %psets)) && die "Cannot find patchset for $name";
1026     return $ps;
1027 }
1028
1029
1030 # an alterative to `command` that allows input to be passed as an array
1031 # to work around shell problems with weird characters in arguments
1032 sub safe_pipe_capture {
1033     my @output;
1034     if (my $pid = open my $child, '-|') {
1035         @output = (<$child>);
1036         close $child or die join(' ',@_).": $! $?";
1037     } else {
1038         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
1039     }
1040     return wantarray ? @output : join('',@output);
1041 }
1042
1043 # `tla logs -rf -d <dir> | head -n1` or `baz tree-id <dir>`
1044 sub arch_tree_id {
1045     my $dir = shift;
1046     chomp( my $ret = (safe_pipe_capture($TLA,'logs','-rf','-d',$dir))[0] );
1047     return $ret;
1048 }
1049
1050 sub archive_reachable {
1051     my $archive = shift;
1052     return 1 if $reachable{$archive};
1053     return 0 if $unreachable{$archive};
1054
1055     if (system "$TLA whereis-archive $archive >/dev/null") {
1056         if ($opt_a && (system($TLA,'register-archive',
1057                       "http://mirrors.sourcecontrol.net/$archive") == 0)) {
1058             $reachable{$archive} = 1;
1059             return 1;
1060         }
1061         print STDERR "Archive is unreachable: $archive\n";
1062         $unreachable{$archive} = 1;
1063         return 0;
1064     } else {
1065         $reachable{$archive} = 1;
1066         return 1;
1067     }
1068 }
1069