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       return 0;
 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     if (my $dirty = `git-diff-files`) {
 582         die "22 Unclean tree when about to process $ps->{id} " .
 583             " - did we fail to commit cleanly before?\n$dirty";
 584     }
 585 }
 586
 587 if ($opt_v) {
 588     foreach (sort keys %stats) {
 589         print" $_: $stats{$_}\n";
 590     }
 591 }
 592 exit 0;
 593
 594 # used by the accurate strategy:
 595 sub sync_to_ps {
 596     my $ps = shift;
 597     my $tree_dir = $tmp.'/'.tree_dirname($ps->{id});
 598
 599     $opt_v && print "sync_to_ps($ps->{id}) method: ";
 600
 601     if (-d $tree_dir) {
 602         if ($ps->{type} eq 't') {
 603             $opt_v && print "get (tag)\n";
 604             # looks like a tag-only or (worse,) a mixed tags/changeset branch,
 605             # can't rely on replay to work correctly on these
 606             rmtree($tree_dir);
 607             safe_pipe_capture($TLA,'get','--no-pristine',$ps->{id},$tree_dir);
 608             $stats{get_tag}++;
 609         } else {
 610                 my $tree_id = arch_tree_id($tree_dir);
 611                 if ($ps->{parent_id} && ($ps->{parent_id} eq $tree_id)) {
 612                     # the common case (hopefully)
 613                     $opt_v && print "replay\n";
 614                     safe_pipe_capture($TLA,'replay','-d',$tree_dir,$ps->{id});
 615                     $stats{replay}++;
 616                 } else {
 617                     # getting one tree is usually faster than getting two trees
 618                     # and applying the delta ...
 619                     rmtree($tree_dir);
 620                     $opt_v && print "apply-delta\n";
 621                     safe_pipe_capture($TLA,'get','--no-pristine',
 622                                         $ps->{id},$tree_dir);
 623                     $stats{get_delta}++;
 624                 }
 625         }
 626     } else {
 627         # new branch work
 628         $opt_v && print "get (new tree)\n";
 629         safe_pipe_capture($TLA,'get','--no-pristine',$ps->{id},$tree_dir);
 630         $stats{get_new}++;
 631     }
 632
 633     # added -I flag to rsync since we're going to fast! AIEEEEE!!!!
 634     system('rsync','-aI','--delete','--exclude',$git_dir,
 635 #               '--exclude','.arch-inventory',
 636                 '--exclude','.arch-ids','--exclude','{arch}',
 637                 '--exclude','+*','--exclude',',*',
 638                 "$tree_dir/",'./') == 0 or die "Cannot rsync $tree_dir: $! $?";
 639     return $tree_dir;
 640 }
 641
 642 sub apply_import {
 643     my $ps = shift;
 644     my $bname = git_branchname($ps->{id});
 645
 646     mkpath($tmp);
 647
 648     safe_pipe_capture($TLA,'get','-s','--no-pristine',$ps->{id},"$tmp/import");
 649     die "Cannot get import: $!" if $?;
 650     system('rsync','-aI','--delete', '--exclude',$git_dir,
 651                 '--exclude','.arch-ids','--exclude','{arch}',
 652                 "$tmp/import/", './');
 653     die "Cannot rsync import:$!" if $?;
 654
 655     rmtree("$tmp/import");
 656     die "Cannot remove tempdir: $!" if $?;
 657
 658
 659     return 1;
 660 }
 661
 662 sub apply_cset {
 663     my $ps = shift;
 664
 665     mkpath($tmp);
 666
 667     # get the changeset
 668     safe_pipe_capture($TLA,'get-changeset',$ps->{id},"$tmp/changeset");
 669     die "Cannot get changeset: $!" if $?;
 670
 671     # apply patches
 672     if (`find $tmp/changeset/patches -type f -name '*.patch'`) {
 673         # this can be sped up considerably by doing
 674         #    (find | xargs cat) | patch
 675         # but that cna get mucked up by patches
 676         # with missing trailing newlines or the standard
 677         # 'missing newline' flag in the patch - possibly
 678         # produced with an old/buggy diff.
 679         # slow and safe, we invoke patch once per patchfile
 680         `find $tmp/changeset/patches -type f -name '*.patch' -print0 | grep -zv '{arch}' | xargs -iFILE -0 --no-run-if-empty patch -p1 --forward -iFILE`;
 681         die "Problem applying patches! $!" if $?;
 682     }
 683
 684     # apply changed binary files
 685     if (my @modified = `find $tmp/changeset/patches -type f -name '*.modified'`) {
 686         foreach my $mod (@modified) {
 687             chomp $mod;
 688             my $orig = $mod;
 689             $orig =~ s/\.modified$//; # lazy
 690             $orig =~ s!^\Q$tmp\E/changeset/patches/!!;
 691             #print "rsync -p '$mod' '$orig'";
 692             system('rsync','-p',$mod,"./$orig");
 693             die "Problem applying binary changes! $!" if $?;
 694         }
 695     }
 696
 697     # bring in new files
 698     system('rsync','-aI','--exclude',$git_dir,
 699                 '--exclude','.arch-ids',
 700                 '--exclude', '{arch}',
 701                 "$tmp/changeset/new-files-archive/",'./');
 702
 703     # deleted files are hinted from the commitlog processing
 704
 705     rmtree("$tmp/changeset");
 706 }
 707
 708
 709 # =for reference
 710 # notes: *-files/-directories keys cannot have spaces, they're always
 711 # pika-escaped.  Everything after the first newline
 712 # A log entry looks like:
 713 # Revision: moodle-org--moodle--1.3.3--patch-15
 714 # Archive: arch-eduforge@catalyst.net.nz--2004
 715 # Creator: Penny Leach <penny@catalyst.net.nz>
 716 # Date: Wed May 25 14:15:34 NZST 2005
 717 # Standard-date: 2005-05-25 02:15:34 GMT
 718 # New-files: lang/de/.arch-ids/block_glossary_random.php.id
 719 #     lang/de/.arch-ids/block_html.php.id
 720 # New-directories: lang/de/help/questionnaire
 721 #     lang/de/help/questionnaire/.arch-ids
 722 # Renamed-files: .arch-ids/db_sears.sql.id db/.arch-ids/db_sears.sql.id
 723 #    db_sears.sql db/db_sears.sql
 724 # Removed-files: lang/be/docs/.arch-ids/release.html.id
 725 #     lang/be/docs/.arch-ids/releaseold.html.id
 726 # Modified-files: admin/cron.php admin/delete.php
 727 #     admin/editor.html backup/lib.php backup/restore.php
 728 # New-patches: arch-eduforge@catalyst.net.nz--2004/moodle-org--moodle--1.3.3--patch-15
 729 # Summary: Updating to latest from MOODLE_14_STABLE (1.4.5+)
 730 #   summary can be multiline with a leading space just like the above fields
 731 # Keywords:
 732 #
 733 # Updating yadda tadda tadda madda
 734 sub parselog {
 735     my ($ps, $log) = @_;
 736     my $key = undef;
 737
 738     # headers we want that contain filenames:
 739     my %want_headers = (
 740         new_files => 1,
 741         modified_files => 1,
 742         renamed_files => 1,
 743         renamed_directories => 1,
 744         removed_files => 1,
 745         removed_directories => 1,
 746     );
 747
 748     chomp (@$log);
 749     while ($_ = shift @$log) {
 750         if (/^Continuation-of:\s*(.*)/) {
 751             $ps->{tag} = $1;
 752             $key = undef;
 753         } elsif (/^Summary:\s*(.*)$/ ) {
 754             # summary can be multiline as long as it has a leading space
 755             $ps->{summary} = [ $1 ];
 756             $key = 'summary';
 757         } elsif (/^Creator: (.*)\s*<([^\>]+)>/) {
 758             $ps->{author} = $1;
 759             $ps->{email} = $2;
 760             $key = undef;
 761         # any *-files or *-directories can be read here:
 762         } elsif (/^([A-Z][a-z\-]+):\s*(.*)$/) {
 763             my $val = $2;
 764             $key = lc $1;
 765             $key =~ tr/-/_/; # too lazy to quote :P
 766             if ($want_headers{$key}) {
 767                 push @{$ps->{$key}}, split(/\s+/, $val);
 768             } else {
 769                 $key = undef;
 770             }
 771         } elsif (/^$/) {
 772             last; # remainder of @$log that didn't get shifted off is message
 773         } elsif ($key) {
 774             if (/^\s+(.*)$/) {
 775                 if ($key eq 'summary') {
 776                     push @{$ps->{$key}}, $1;
 777                 } else { # files/directories:
 778                     push @{$ps->{$key}}, split(/\s+/, $1);
 779                 }
 780             } else {
 781                 $key = undef;
 782             }
 783         }
 784     }
 785
 786     # post-processing:
 787     $ps->{summary} = join("\n",@{$ps->{summary}})."\n";
 788     $ps->{message} = join("\n",@$log);
 789
 790     # skip Arch control files, unescape pika-escaped files
 791     foreach my $k (keys %want_headers) {
 792         next unless (defined $ps->{$k});
 793         my @tmp;
 794         foreach my $t (@{$ps->{$k}}) {
 795            next unless length ($t);
 796            next if $t =~ m!\{arch\}/!;
 797            next if $t =~ m!\.arch-ids/!;
 798            # should we skip this?
 799            next if $t =~ m!\.arch-inventory$!;
 800            # tla cat-archive-log will give us filenames with spaces as file\(sp)name - why?
 801            # we can assume that any filename with \ indicates some pika escaping that we want to get rid of.
 802            if ($t =~ /\\/ ){
 803                $t = (safe_pipe_capture($TLA,'escape','--unescaped',$t))[0];
 804            }
 805            push @tmp, $t;
 806         }
 807         $ps->{$k} = \@tmp if scalar @tmp;
 808     }
 809 }
 810
 811 # write/read a tag
 812 sub tag {
 813     my ($tag, $commit) = @_;
 814
 815     if ($opt_o) {
 816         $tag =~ s|/|--|g;
 817     } else {
 818         # don't use subdirs for tags yet, it could screw up other porcelains
 819         $tag =~ s|/|,|g;
 820     }
 821
 822     if ($commit) {
 823         open(C,">","$git_dir/refs/tags/$tag")
 824             or die "Cannot create tag $tag: $!\n";
 825         print C "$commit\n"
 826             or die "Cannot write tag $tag: $!\n";
 827         close(C)
 828             or die "Cannot write tag $tag: $!\n";
 829         print " * Created tag '$tag' on '$commit'\n" if $opt_v;
 830     } else {                    # read
 831         open(C,"<","$git_dir/refs/tags/$tag")
 832             or die "Cannot read tag $tag: $!\n";
 833         $commit = <C>;
 834         chomp $commit;
 835         die "Error reading tag $tag: $!\n" unless length $commit == 40;
 836         close(C)
 837             or die "Cannot read tag $tag: $!\n";
 838         return $commit;
 839     }
 840 }
 841
 842 # write/read a private tag
 843 # reads fail softly if the tag isn't there
 844 sub ptag {
 845     my ($tag, $commit) = @_;
 846
 847     # don't use subdirs for tags yet, it could screw up other porcelains
 848     $tag =~ s|/|,|g;
 849
 850     my $tag_file = "$ptag_dir/$tag";
 851     my $tag_branch_dir = dirname($tag_file);
 852     mkpath($tag_branch_dir) unless (-d $tag_branch_dir);
 853
 854     if ($commit) {              # write
 855         open(C,">",$tag_file)
 856             or die "Cannot create tag $tag: $!\n";
 857         print C "$commit\n"
 858             or die "Cannot write tag $tag: $!\n";
 859         close(C)
 860             or die "Cannot write tag $tag: $!\n";
 861         $rptags{$commit} = $tag
 862             unless $tag =~ m/--base-0$/;
 863     } else {                    # read
 864         # if the tag isn't there, return 0
 865         unless ( -s $tag_file) {
 866             return 0;
 867         }
 868         open(C,"<",$tag_file)
 869             or die "Cannot read tag $tag: $!\n";
 870         $commit = <C>;
 871         chomp $commit;
 872         die "Error reading tag $tag: $!\n" unless length $commit == 40;
 873         close(C)
 874             or die "Cannot read tag $tag: $!\n";
 875         unless (defined $rptags{$commit}) {
 876             $rptags{$commit} = $tag;
 877         }
 878         return $commit;
 879     }
 880 }
 881
 882 sub find_parents {
 883     #
 884     # Identify what branches are merging into me
 885     # and whether we are fully merged
 886     # git-merge-base <headsha> <headsha> should tell
 887     # me what the base of the merge should be
 888     #
 889     my $ps = shift;
 890
 891     my %branches; # holds an arrayref per branch
 892                   # the arrayref contains a list of
 893                   # merged patches between the base
 894                   # of the merge and the current head
 895
 896     my @parents;  # parents found for this commit
 897
 898     # simple loop to split the merges
 899     # per branch
 900     foreach my $merge (@{$ps->{merges}}) {
 901         my $branch = git_branchname($merge);
 902         unless (defined $branches{$branch} ){
 903             $branches{$branch} = [];
 904         }
 905         push @{$branches{$branch}}, $merge;
 906     }
 907
 908     #
 909     # foreach branch find a merge base and walk it to the
 910     # head where we are, collecting the merged patchsets that
 911     # Arch has recorded. Keep that in @have
 912     # Compare that with the commits on the other branch
 913     # between merge-base and the tip of the branch (@need)
 914     # and see if we have a series of consecutive patches
 915     # starting from the merge base. The tip of the series
 916     # of consecutive patches merged is our new parent for
 917     # that branch.
 918     #
 919     foreach my $branch (keys %branches) {
 920
 921         # check that we actually know about the branch
 922         next unless -e "$git_dir/refs/heads/$branch";
 923
 924         my $mergebase = `git-merge-base $branch $ps->{branch}`;
 925         if ($?) {
 926             # Don't die here, Arch supports one-way cherry-picking
 927             # between branches with no common base (or any relationship
 928             # at all beforehand)
 929             warn "Cannot find merge base for $branch and $ps->{branch}";
 930             next;
 931         }
 932         chomp $mergebase;
 933
 934         # now walk up to the mergepoint collecting what patches we have
 935         my $branchtip = git_rev_parse($ps->{branch});
 936         my @ancestors = `git-rev-list --merge-order $branchtip ^$mergebase`;
 937         my %have; # collected merges this branch has
 938         foreach my $merge (@{$ps->{merges}}) {
 939             $have{$merge} = 1;
 940         }
 941         my %ancestorshave;
 942         foreach my $par (@ancestors) {
 943             $par = commitid2pset($par);
 944             if (defined $par->{merges}) {
 945                 foreach my $merge (@{$par->{merges}}) {
 946                     $ancestorshave{$merge}=1;
 947                 }
 948             }
 949         }
 950         # print "++++ Merges in $ps->{id} are....\n";
 951         # my @have = sort keys %have;   print Dumper(\@have);
 952
 953         # merge what we have with what ancestors have
 954         %have = (%have, %ancestorshave);
 955
 956         # see what the remote branch has - these are the merges we
 957         # will want to have in a consecutive series from the mergebase
 958         my $otherbranchtip = git_rev_parse($branch);
 959         my @needraw = `git-rev-list --merge-order $otherbranchtip ^$mergebase`;
 960         my @need;
 961         foreach my $needps (@needraw) {         # get the psets
 962             $needps = commitid2pset($needps);
 963             # git-rev-list will also
 964             # list commits merged in via earlier
 965             # merges. we are only interested in commits
 966             # from the branch we're looking at
 967             if ($branch eq $needps->{branch}) {
 968                 push @need, $needps->{id};
 969             }
 970         }
 971
 972         # print "++++ Merges from $branch we want are....\n";
 973         # print Dumper(\@need);
 974
 975         my $newparent;
 976         while (my $needed_commit = pop @need) {
 977             if ($have{$needed_commit}) {
 978                 $newparent = $needed_commit;
 979             } else {
 980                 last; # break out of the while
 981             }
 982         }
 983         if ($newparent) {
 984             push @parents, $newparent;
 985         }
 986
 987
 988     } # end foreach branch
 989
 990     # prune redundant parents
 991     my %parents;
 992     foreach my $p (@parents) {
 993         $parents{$p} = 1;
 994     }
 995     foreach my $p (@parents) {
 996         next unless exists $psets{$p}{merges};
 997         next unless ref    $psets{$p}{merges};
 998         my @merges = @{$psets{$p}{merges}};
 999         foreach my $merge (@merges) {
1000             if ($parents{$merge}) {
1001                 delete $parents{$merge};
1002             }
1003         }
1004     }
1005
1006     @parents = ();
1007     foreach (keys %parents) {
1008         push @parents, '-p', ptag($_);
1009     }
1010     return @parents;
1011 }
1012
1013 sub git_rev_parse {
1014     my $name = shift;
1015     my $val  = `git-rev-parse $name`;
1016     die "Error: git-rev-parse $name" if $?;
1017     chomp $val;
1018     return $val;
1019 }
1020
1021 # resolve a SHA1 to a known patchset
1022 sub commitid2pset {
1023     my $commitid = shift;
1024     chomp $commitid;
1025     my $name = $rptags{$commitid}
1026         || die "Cannot find reverse tag mapping for $commitid";
1027     $name =~ s|,|/|;
1028     my $ps   = $psets{$name}
1029         || (print Dumper(sort keys %psets)) && die "Cannot find patchset for $name";
1030     return $ps;
1031 }
1032
1033
1034 # an alterative to `command` that allows input to be passed as an array
1035 # to work around shell problems with weird characters in arguments
1036 sub safe_pipe_capture {
1037     my @output;
1038     if (my $pid = open my $child, '-|') {
1039         @output = (<$child>);
1040         close $child or die join(' ',@_).": $! $?";
1041     } else {
1042         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
1043     }
1044     return wantarray ? @output : join('',@output);
1045 }
1046
1047 # `tla logs -rf -d <dir> | head -n1` or `baz tree-id <dir>`
1048 sub arch_tree_id {
1049     my $dir = shift;
1050     chomp( my $ret = (safe_pipe_capture($TLA,'logs','-rf','-d',$dir))[0] );
1051     return $ret;
1052 }
1053
1054 sub archive_reachable {
1055     my $archive = shift;
1056     return 1 if $reachable{$archive};
1057     return 0 if $unreachable{$archive};
1058
1059     if (system "$TLA whereis-archive $archive >/dev/null") {
1060         if ($opt_a && (system($TLA,'register-archive',
1061                       "http://mirrors.sourcecontrol.net/$archive") == 0)) {
1062             $reachable{$archive} = 1;
1063             return 1;
1064         }
1065         print STDERR "Archive is unreachable: $archive\n";
1066         $unreachable{$archive} = 1;
1067         return 0;
1068     } else {
1069         $reachable{$archive} = 1;
1070         return 1;
1071     }
1072 }
1073