git

1
#!/usr/bin/perl
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 ] [ -o ] [ -a ] [ -f ] [ -T ]
13
	[ -D depth] [ -t tempdir ] <archive>/<branch> [ <archive>/<branch> ]
14

15
Imports a project from one or more Arch repositories. It will follow branches
16
and repositories within the namespaces defined by the <archive/branch>
17
parameters supplied. If it cannot find the remote branch a merge comes from
18
it will just import it as a regular commit. If it can find it, it will mark it
19
as a merge whenever possible.
20

21
See man (1) git-archimport for more details.
22

23
=head1 TODO
24

25
 - create tag objects instead of ref tags
26
 - audit shell-escaping of filenames
27
 - hide our private tags somewhere smarter
28
 - find a way to make "cat *patches | patch" safe even when patchfiles are missing newlines
29
 - sort and apply patches by graphing ancestry relations instead of just
30
   relying in dates supplied in the changeset itself.
31
   tla ancestry-graph -m could be helpful here...
32

33
=head1 Devel tricks
34

35
Add print in front of the shell commands invoked via backticks.
36

37
=head1 Devel Notes
38

39
There are several places where Arch and git terminology are intermixed
40
and potentially confused.
41

42
The notion of a "branch" in git is approximately equivalent to
43
a "archive/category--branch--version" in Arch.  Also, it should be noted
44
that the "--branch" portion of "archive/category--branch--version" is really
45
optional in Arch although not many people (nor tools!) seem to know this.
46
This means that "archive/category--version" is also a valid "branch"
47
in git terms.
48

49
We always refer to Arch names by their fully qualified variant (which
50
means the "archive" name is prefixed.
51

52
For people unfamiliar with Arch, an "archive" is the term for "repository",
53
and can contain multiple, unrelated branches.
54

55
=cut
56

57
use 5.008001;
58
use strict;
59
use warnings;
60
use Getopt::Std;
61
use File::Temp qw(tempdir);
62
use File::Path qw(mkpath rmtree);
63
use File::Basename qw(basename dirname);
64
use Data::Dumper qw/ Dumper /;
65
use IPC::Open2;
66

67
$SIG{'PIPE'}="IGNORE";
68
$ENV{'TZ'}="UTC";
69

70
my $git_dir = $ENV{"GIT_DIR"} || ".git";
71
$ENV{"GIT_DIR"} = $git_dir;
72
my $ptag_dir = "$git_dir/archimport/tags";
73

74
our($opt_h,$opt_f,$opt_v,$opt_T,$opt_t,$opt_D,$opt_a,$opt_o);
75

76
sub usage() {
77
    print STDERR <<END;
78
usage: git archimport     # fetch/update GIT from Arch
79
       [ -h ] [ -v ] [ -o ] [ -a ] [ -f ] [ -T ] [ -D depth ] [ -t tempdir ]
80
       repository/arch-branch [ repository/arch-branch] ...
81
END
82
    exit(1);
83
}
84

85
getopts("fThvat:D:") or usage();
86
usage if $opt_h;
87

88
@ARGV >= 1 or usage();
89
# $arch_branches:
90
# values associated with keys:
91
#   =1 - Arch version / git 'branch' detected via abrowse on a limit
92
#   >1 - Arch version / git 'branch' of an auxiliary branch we've merged
93
my %arch_branches = map { my $branch = $_; $branch =~ s/:[^:]*$//; $branch => 1 } @ARGV;
94

95
# $branch_name_map:
96
# maps arch branches to git branch names
97
my %branch_name_map = map { m/^(.*):([^:]*)$/; $1 => $2 } grep { m/:/ } @ARGV;
98

99
$ENV{'TMPDIR'} = $opt_t if $opt_t; # $ENV{TMPDIR} will affect tempdir() calls:
100
my $tmp = tempdir('git-archimport-XXXXXX', TMPDIR => 1, CLEANUP => 1);
101
$opt_v && print "+ Using $tmp as temporary directory\n";
102

103
unless (-d $git_dir) { # initial import needs empty directory
104
    opendir DIR, '.' or die "Unable to open current directory: $!\n";
105
    while (my $entry = readdir DIR) {
106
        $entry =~ /^\.\.?$/ or
107
            die "Initial import needs an empty current working directory.\n"
108
    }
109
    closedir DIR
110
}
111

112
my $default_archive;		# default Arch archive
113
my %reachable = ();             # Arch repositories we can access
114
my %unreachable = ();           # Arch repositories we can't access :<
115
my @psets  = ();                # the collection
116
my %psets  = ();                # the collection, by name
117
my %stats  = (			# Track which strategy we used to import:
118
	get_tag => 0, replay => 0, get_new => 0, get_delta => 0,
119
        simple_changeset => 0, import_or_tag => 0
120
);
121

122
my %rptags = ();                # my reverse private tags
123
                                # to map a SHA1 to a commitid
124
my $TLA = $ENV{'ARCH_CLIENT'} || 'tla';
125

126
sub do_abrowse {
127
    my $stage = shift;
128
    while (my ($limit, $level) = each %arch_branches) {
129
        next unless $level == $stage;
130

131
	open ABROWSE, "$TLA abrowse -fkD --merges $limit |"
132
                                or die "Problems with tla abrowse: $!";
133

134
        my %ps        = ();         # the current one
135
        my $lastseen  = '';
136

137
        while (<ABROWSE>) {
138
            chomp;
139

140
            # first record padded w 8 spaces
141
            if (s/^\s{8}\b//) {
142
                my ($id, $type) = split(m/\s+/, $_, 2);
143

144
                my %last_ps;
145
                # store the record we just captured
146
                if (%ps && !exists $psets{ $ps{id} }) {
147
                    %last_ps = %ps; # break references
148
                    push (@psets, \%last_ps);
149
                    $psets{ $last_ps{id} } = \%last_ps;
150
                }
151

152
                my $branch = extract_versionname($id);
153
                %ps = ( id => $id, branch => $branch );
154
                if (%last_ps && ($last_ps{branch} eq $branch)) {
155
                    $ps{parent_id} = $last_ps{id};
156
                }
157

158
                $arch_branches{$branch} = 1;
159
                $lastseen = 'id';
160

161
                # deal with types (should work with baz or tla):
162
                if ($type =~ m/\(.*changeset\)/) {
163
                    $ps{type} = 's';
164
                } elsif ($type =~ /\(.*import\)/) {
165
                    $ps{type} = 'i';
166
                } elsif ($type =~ m/\(tag.*?(\S+\@\S+).*?\)/) {
167
                    $ps{type} = 't';
168
                    # read which revision we've tagged when we parse the log
169
                    $ps{tag}  = $1;
170
                } else {
171
                    warn "Unknown type $type";
172
                }
173

174
                $arch_branches{$branch} = 1;
175
                $lastseen = 'id';
176
            } elsif (s/^\s{10}//) {
177
                # 10 leading spaces or more
178
                # indicate commit metadata
179

180
                # date
181
                if ($lastseen eq 'id' && m/^(\d{4}-\d\d-\d\d \d\d:\d\d:\d\d)/){
182
                    $ps{date}   = $1;
183
                    $lastseen = 'date';
184
                } elsif ($_ eq 'merges in:') {
185
                    $ps{merges} = [];
186
                    $lastseen = 'merges';
187
                } elsif ($lastseen eq 'merges' && s/^\s{2}//) {
188
                    my $id = $_;
189
                    push (@{$ps{merges}}, $id);
190

191
                    # aggressive branch finding:
192
                    if ($opt_D) {
193
                        my $branch = extract_versionname($id);
194
                        my $repo = extract_reponame($branch);
195

196
                        if (archive_reachable($repo) &&
197
                                !defined $arch_branches{$branch}) {
198
                            $arch_branches{$branch} = $stage + 1;
199
                        }
200
                    }
201
                } else {
202
                    warn "more metadata after merges!?: $_\n" unless /^\s*$/;
203
                }
204
            }
205
        }
206

207
        if (%ps && !exists $psets{ $ps{id} }) {
208
            my %temp = %ps;         # break references
209
            if (@psets && $psets[$#psets]{branch} eq $ps{branch}) {
210
                $temp{parent_id} = $psets[$#psets]{id};
211
            }
212
            push (@psets, \%temp);
213
            $psets{ $temp{id} } = \%temp;
214
        }
215

216
        close ABROWSE or die "$TLA abrowse failed on $limit\n";
217
    }
218
}                               # end foreach $root
219

220
do_abrowse(1);
221
my $depth = 2;
222
$opt_D ||= 0;
223
while ($depth <= $opt_D) {
224
    do_abrowse($depth);
225
    $depth++;
226
}
227

228
## Order patches by time
229
# FIXME see if we can find a more optimal way to do this by graphing
230
# the ancestry data and walking it, that way we won't have to rely on
231
# client-supplied dates
232
@psets = sort {$a->{date}.$b->{id} cmp $b->{date}.$b->{id}} @psets;
233

234
#print Dumper \@psets;
235

236
##
237
## TODO cleanup irrelevant patches
238
##      and put an initial import
239
##      or a full tag
240
my $import = 0;
241
unless (-d $git_dir) { # initial import
242
    if ($psets[0]{type} eq 'i' || $psets[0]{type} eq 't') {
243
        print "Starting import from $psets[0]{id}\n";
244
	`git-init`;
245
	die $! if $?;
246
	$import = 1;
247
    } else {
248
        die "Need to start from an import or a tag -- cannot use $psets[0]{id}";
249
    }
250
} else {    # progressing an import
251
    # load the rptags
252
    opendir(DIR, $ptag_dir)
253
	|| die "can't opendir: $!";
254
    while (my $file = readdir(DIR)) {
255
        # skip non-interesting-files
256
        next unless -f "$ptag_dir/$file";
257

258
        # convert first '--' to '/' from old git-archimport to use
259
        # as an archivename/c--b--v private tag
260
        if ($file !~ m!,!) {
261
            my $oldfile = $file;
262
            $file =~ s!--!,!;
263
            print STDERR "converting old tag $oldfile to $file\n";
264
            rename("$ptag_dir/$oldfile", "$ptag_dir/$file") or die $!;
265
        }
266
	my $sha = ptag($file);
267
	chomp $sha;
268
	$rptags{$sha} = $file;
269
    }
270
    closedir DIR;
271
}
272

273
# process patchsets
274
# extract the Arch repository name (Arch "archive" in Arch-speak)
275
sub extract_reponame {
276
    my $fq_cvbr = shift; # archivename/[[[[category]branch]version]revision]
277
    return (split(/\//, $fq_cvbr))[0];
278
}
279

280
sub extract_versionname {
281
    my $name = shift;
282
    $name =~ s/--(?:patch|version(?:fix)?|base)-\d+$//;
283
    return $name;
284
}
285

286
# convert a fully-qualified revision or version to a unique dirname:
287
#   normalperson@yhbt.net-05/mpd--uclinux--1--patch-2
288
# becomes: normalperson@yhbt.net-05,mpd--uclinux--1
289
#
290
# the git notion of a branch is closer to
291
# archive/category--branch--version than archive/category--branch, so we
292
# use this to convert to git branch names.
293
# Also, keep archive names but replace '/' with ',' since it won't require
294
# subdirectories, and is safer than swapping '--' which could confuse
295
# reverse-mapping when dealing with bastard branches that
296
# are just archive/category--version  (no --branch)
297
sub tree_dirname {
298
    my $revision = shift;
299
    my $name = extract_versionname($revision);
300
    $name =~ s#/#,#;
301
    return $name;
302
}
303

304
# old versions of git-archimport just use the <category--branch> part:
305
sub old_style_branchname {
306
    my $id = shift;
307
    my $ret = safe_pipe_capture($TLA,'parse-package-name','-p',$id);
308
    chomp $ret;
309
    return $ret;
310
}
311

312
*git_default_branchname = $opt_o ? *old_style_branchname : *tree_dirname;
313

314
# retrieve default archive, since $branch_name_map keys might not include it
315
sub get_default_archive {
316
    if (!defined $default_archive) {
317
        $default_archive = safe_pipe_capture($TLA,'my-default-archive');
318
        chomp $default_archive;
319
    }
320
    return $default_archive;
321
}
322

323
sub git_branchname {
324
    my $revision = shift;
325
    my $name = extract_versionname($revision);
326

327
    if (exists $branch_name_map{$name}) {
328
	return $branch_name_map{$name};
329

330
    } elsif ($name =~ m#^([^/]*)/(.*)$#
331
	     && $1 eq get_default_archive()
332
	     && exists $branch_name_map{$2}) {
333
	# the names given in the command-line lacked the archive.
334
	return $branch_name_map{$2};
335

336
    } else {
337
	return git_default_branchname($revision);
338
    }
339
}
340

341
sub process_patchset_accurate {
342
    my $ps = shift;
343

344
    # switch to that branch if we're not already in that branch:
345
    if (-e "$git_dir/refs/heads/$ps->{branch}") {
346
       system('git-checkout','-f',$ps->{branch}) == 0 or die "$! $?\n";
347

348
       # remove any old stuff that got leftover:
349
       my $rm = safe_pipe_capture('git-ls-files','--others','-z');
350
       rmtree(split(/\0/,$rm)) if $rm;
351
    }
352

353
    # Apply the import/changeset/merge into the working tree
354
    my $dir = sync_to_ps($ps);
355
    # read the new log entry:
356
    my @commitlog = safe_pipe_capture($TLA,'cat-log','-d',$dir,$ps->{id});
357
    die "Error in cat-log: $!" if $?;
358
    chomp @commitlog;
359

360
    # grab variables we want from the log, new fields get added to $ps:
361
    # (author, date, email, summary, message body ...)
362
    parselog($ps, \@commitlog);
363

364
    if ($ps->{id} =~ /--base-0$/ && $ps->{id} ne $psets[0]{id}) {
365
        # this should work when importing continuations
366
        if ($ps->{tag} && (my $branchpoint = eval { ptag($ps->{tag}) })) {
367

368
            # find where we are supposed to branch from
369
	    if (! -e "$git_dir/refs/heads/$ps->{branch}") {
370
		system('git-branch',$ps->{branch},$branchpoint) == 0 or die "$! $?\n";
371

372
		# We trust Arch with the fact that this is just a tag,
373
		# and it does not affect the state of the tree, so
374
		# we just tag and move on.  If the user really wants us
375
		# to consolidate more branches into one, don't tag because
376
		# the tag name would be already taken.
377
		tag($ps->{id}, $branchpoint);
378
		ptag($ps->{id}, $branchpoint);
379
		print " * Tagged $ps->{id} at $branchpoint\n";
380
	    }
381
	    system('git-checkout','-f',$ps->{branch}) == 0 or die "$! $?\n";
382

383
            # remove any old stuff that got leftover:
384
            my $rm = safe_pipe_capture('git-ls-files','--others','-z');
385
            rmtree(split(/\0/,$rm)) if $rm;
386
            return 0;
387
        } else {
388
            warn "Tagging from unknown id unsupported\n" if $ps->{tag};
389
        }
390
        # allow multiple bases/imports here since Arch supports cherry-picks
391
        # from unrelated trees
392
    }
393

394
    # update the index with all the changes we got
395
    system('git-diff-files --name-only -z | '.
396
            'git-update-index --remove -z --stdin') == 0 or die "$! $?\n";
397
    system('git-ls-files --others -z | '.
398
            'git-update-index --add -z --stdin') == 0 or die "$! $?\n";
399
    return 1;
400
}
401

402
# the native changeset processing strategy.  This is very fast, but
403
# does not handle permissions or any renames involving directories
404
sub process_patchset_fast {
405
    my $ps = shift;
406
    #
407
    # create the branch if needed
408
    #
409
    if ($ps->{type} eq 'i' && !$import) {
410
        die "Should not have more than one 'Initial import' per GIT import: $ps->{id}";
411
    }
412

413
    unless ($import) { # skip for import
414
        if ( -e "$git_dir/refs/heads/$ps->{branch}") {
415
            # we know about this branch
416
            system('git-checkout',$ps->{branch});
417
        } else {
418
            # new branch! we need to verify a few things
419
            die "Branch on a non-tag!" unless $ps->{type} eq 't';
420
            my $branchpoint = ptag($ps->{tag});
421
            die "Tagging from unknown id unsupported: $ps->{tag}"
422
                unless $branchpoint;
423

424
            # find where we are supposed to branch from
425
	    if (! -e "$git_dir/refs/heads/$ps->{branch}") {
426
		system('git-branch',$ps->{branch},$branchpoint) == 0 or die "$! $?\n";
427

428
		# We trust Arch with the fact that this is just a tag,
429
		# and it does not affect the state of the tree, so
430
		# we just tag and move on.  If the user really wants us
431
		# to consolidate more branches into one, don't tag because
432
		# the tag name would be already taken.
433
		tag($ps->{id}, $branchpoint);
434
		ptag($ps->{id}, $branchpoint);
435
		print " * Tagged $ps->{id} at $branchpoint\n";
436
            }
437
            system('git-checkout',$ps->{branch}) == 0 or die "$! $?\n";
438
            return 0;
439
        }
440
        die $! if $?;
441
    }
442

443
    #
444
    # Apply the import/changeset/merge into the working tree
445
    #
446
    if ($ps->{type} eq 'i' || $ps->{type} eq 't') {
447
        apply_import($ps) or die $!;
448
        $stats{import_or_tag}++;
449
        $import=0;
450
    } elsif ($ps->{type} eq 's') {
451
        apply_cset($ps);
452
        $stats{simple_changeset}++;
453
    }
454

455
    #
456
    # prepare update git's index, based on what arch knows
457
    # about the pset, resolve parents, etc
458
    #
459

460
    my @commitlog = safe_pipe_capture($TLA,'cat-archive-log',$ps->{id});
461
    die "Error in cat-archive-log: $!" if $?;
462

463
    parselog($ps,\@commitlog);
464

465
    # imports don't give us good info
466
    # on added files. Shame on them
467
    if ($ps->{type} eq 'i' || $ps->{type} eq 't') {
468
        system('git-ls-files --deleted -z | '.
469
                'git-update-index --remove -z --stdin') == 0 or die "$! $?\n";
470
        system('git-ls-files --others -z | '.
471
                'git-update-index --add -z --stdin') == 0 or die "$! $?\n";
472
    }
473

474
    # TODO: handle removed_directories and renamed_directories:
475

476
    if (my $del = $ps->{removed_files}) {
477
        unlink @$del;
478
        while (@$del) {
479
            my @slice = splice(@$del, 0, 100);
480
            system('git-update-index','--remove','--',@slice) == 0 or
481
                            die "Error in git-update-index --remove: $! $?\n";
482
        }
483
    }
484

485
    if (my $ren = $ps->{renamed_files}) {                # renamed
486
        if (@$ren % 2) {
487
            die "Odd number of entries in rename!?";
488
        }
489

490
        while (@$ren) {
491
            my $from = shift @$ren;
492
            my $to   = shift @$ren;
493

494
            unless (-d dirname($to)) {
495
                mkpath(dirname($to)); # will die on err
496
            }
497
            # print "moving $from $to";
498
            rename($from, $to) or die "Error renaming '$from' '$to': $!\n";
499
            system('git-update-index','--remove','--',$from) == 0 or
500
                            die "Error in git-update-index --remove: $! $?\n";
501
            system('git-update-index','--add','--',$to) == 0 or
502
                            die "Error in git-update-index --add: $! $?\n";
503
        }
504
    }
505

506
    if (my $add = $ps->{new_files}) {
507
        while (@$add) {
508
            my @slice = splice(@$add, 0, 100);
509
            system('git-update-index','--add','--',@slice) == 0 or
510
                            die "Error in git-update-index --add: $! $?\n";
511
        }
512
    }
513

514
    if (my $mod = $ps->{modified_files}) {
515
        while (@$mod) {
516
            my @slice = splice(@$mod, 0, 100);
517
            system('git-update-index','--',@slice) == 0 or
518
                            die "Error in git-update-index: $! $?\n";
519
        }
520
    }
521
    return 1; # we successfully applied the changeset
522
}
523

524
if ($opt_f) {
525
    print "Will import patchsets using the fast strategy\n",
526
            "Renamed directories and permission changes will be missed\n";
527
    *process_patchset = *process_patchset_fast;
528
} else {
529
    print "Using the default (accurate) import strategy.\n",
530
            "Things may be a bit slow\n";
531
    *process_patchset = *process_patchset_accurate;
532
}
533

534
foreach my $ps (@psets) {
535
    # process patchsets
536
    $ps->{branch} = git_branchname($ps->{id});
537

538
    #
539
    # ensure we have a clean state
540
    #
541
    if (my $dirty = `git-diff-files`) {
542
        die "Unclean tree when about to process $ps->{id} " .
543
            " - did we fail to commit cleanly before?\n$dirty";
544
    }
545
    die $! if $?;
546

547
    #
548
    # skip commits already in repo
549
    #
550
    if (ptag($ps->{id})) {
551
      $opt_v && print " * Skipping already imported: $ps->{id}\n";
552
      next;
553
    }
554

555
    print " * Starting to work on $ps->{id}\n";
556

557
    process_patchset($ps) or next;
558

559
    # warn "errors when running git-update-index! $!";
560
    my $tree = `git-write-tree`;
561
    die "cannot write tree $!" if $?;
562
    chomp $tree;
563

564
    #
565
    # Who's your daddy?
566
    #
567
    my @par;
568
    if ( -e "$git_dir/refs/heads/$ps->{branch}") {
569
        if (open HEAD, "<","$git_dir/refs/heads/$ps->{branch}") {
570
            my $p = <HEAD>;
571
            close HEAD;
572
            chomp $p;
573
            push @par, '-p', $p;
574
        } else {
575
            if ($ps->{type} eq 's') {
576
                warn "Could not find the right head for the branch $ps->{branch}";
577
            }
578
        }
579
    }
580

581
    if ($ps->{merges}) {
582
        push @par, find_parents($ps);
583
    }
584

585
    #
586
    # Commit, tag and clean state
587
    #
588
    $ENV{TZ}                  = 'GMT';
589
    $ENV{GIT_AUTHOR_NAME}     = $ps->{author};
590
    $ENV{GIT_AUTHOR_EMAIL}    = $ps->{email};
591
    $ENV{GIT_AUTHOR_DATE}     = $ps->{date};
592
    $ENV{GIT_COMMITTER_NAME}  = $ps->{author};
593
    $ENV{GIT_COMMITTER_EMAIL} = $ps->{email};
594
    $ENV{GIT_COMMITTER_DATE}  = $ps->{date};
595

596
    my $pid = open2(*READER, *WRITER,'git-commit-tree',$tree,@par)
597
        or die $!;
598
    print WRITER $ps->{summary},"\n\n";
599

600
    # only print message if it's not empty, to avoid a spurious blank line;
601
    # also append an extra newline, so there's a blank line before the
602
    # following "git-archimport-id:" line.
603
    print WRITER $ps->{message},"\n\n" if ($ps->{message} ne "");
604

605
    # make it easy to backtrack and figure out which Arch revision this was:
606
    print WRITER 'git-archimport-id: ',$ps->{id},"\n";
607

608
    close WRITER;
609
    my $commitid = <READER>;    # read
610
    chomp $commitid;
611
    close READER;
612
    waitpid $pid,0;             # close;
613

614
    if (length $commitid != 40) {
615
        die "Something went wrong with the commit! $! $commitid";
616
    }
617
    #
618
    # Update the branch
619
    #
620
    open  HEAD, ">","$git_dir/refs/heads/$ps->{branch}";
621
    print HEAD $commitid;
622
    close HEAD;
623
    system('git-update-ref', 'HEAD', "$ps->{branch}");
624

625
    # tag accordingly
626
    ptag($ps->{id}, $commitid); # private tag
627
    if ($opt_T || $ps->{type} eq 't' || $ps->{type} eq 'i') {
628
        tag($ps->{id}, $commitid);
629
    }
630
    print " * Committed $ps->{id}\n";
631
    print "   + tree   $tree\n";
632
    print "   + commit $commitid\n";
633
    $opt_v && print "   + commit date is  $ps->{date} \n";
634
    $opt_v && print "   + parents:  ",join(' ',@par),"\n";
635
}
636

637
if ($opt_v) {
638
    foreach (sort keys %stats) {
639
        print" $_: $stats{$_}\n";
640
    }
641
}
642
exit 0;
643

644
# used by the accurate strategy:
645
sub sync_to_ps {
646
    my $ps = shift;
647
    my $tree_dir = $tmp.'/'.tree_dirname($ps->{id});
648

649
    $opt_v && print "sync_to_ps($ps->{id}) method: ";
650

651
    if (-d $tree_dir) {
652
        if ($ps->{type} eq 't') {
653
	    $opt_v && print "get (tag)\n";
654
            # looks like a tag-only or (worse,) a mixed tags/changeset branch,
655
            # can't rely on replay to work correctly on these
656
            rmtree($tree_dir);
657
            safe_pipe_capture($TLA,'get','--no-pristine',$ps->{id},$tree_dir);
658
            $stats{get_tag}++;
659
        } else {
660
                my $tree_id = arch_tree_id($tree_dir);
661
                if ($ps->{parent_id} && ($ps->{parent_id} eq $tree_id)) {
662
                    # the common case (hopefully)
663
		    $opt_v && print "replay\n";
664
                    safe_pipe_capture($TLA,'replay','-d',$tree_dir,$ps->{id});
665
                    $stats{replay}++;
666
                } else {
667
                    # getting one tree is usually faster than getting two trees
668
                    # and applying the delta ...
669
                    rmtree($tree_dir);
670
		    $opt_v && print "apply-delta\n";
671
                    safe_pipe_capture($TLA,'get','--no-pristine',
672
                                        $ps->{id},$tree_dir);
673
                    $stats{get_delta}++;
674
                }
675
        }
676
    } else {
677
        # new branch work
678
        $opt_v && print "get (new tree)\n";
679
        safe_pipe_capture($TLA,'get','--no-pristine',$ps->{id},$tree_dir);
680
        $stats{get_new}++;
681
    }
682

683
    # added -I flag to rsync since we're going to fast! AIEEEEE!!!!
684
    system('rsync','-aI','--delete','--exclude',$git_dir,
685
#               '--exclude','.arch-inventory',
686
                '--exclude','.arch-ids','--exclude','{arch}',
687
                '--exclude','+*','--exclude',',*',
688
                "$tree_dir/",'./') == 0 or die "Cannot rsync $tree_dir: $! $?";
689
    return $tree_dir;
690
}
691

692
sub apply_import {
693
    my $ps = shift;
694
    my $bname = git_branchname($ps->{id});
695

696
    mkpath($tmp);
697

698
    safe_pipe_capture($TLA,'get','-s','--no-pristine',$ps->{id},"$tmp/import");
699
    die "Cannot get import: $!" if $?;
700
    system('rsync','-aI','--delete', '--exclude',$git_dir,
701
		'--exclude','.arch-ids','--exclude','{arch}',
702
		"$tmp/import/", './');
703
    die "Cannot rsync import:$!" if $?;
704

705
    rmtree("$tmp/import");
706
    die "Cannot remove tempdir: $!" if $?;
707

708

709
    return 1;
710
}
711

712
sub apply_cset {
713
    my $ps = shift;
714

715
    mkpath($tmp);
716

717
    # get the changeset
718
    safe_pipe_capture($TLA,'get-changeset',$ps->{id},"$tmp/changeset");
719
    die "Cannot get changeset: $!" if $?;
720

721
    # apply patches
722
    if (`find $tmp/changeset/patches -type f -name '*.patch'`) {
723
        # this can be sped up considerably by doing
724
        #    (find | xargs cat) | patch
725
        # but that can get mucked up by patches
726
        # with missing trailing newlines or the standard
727
        # 'missing newline' flag in the patch - possibly
728
        # produced with an old/buggy diff.
729
        # slow and safe, we invoke patch once per patchfile
730
        `find $tmp/changeset/patches -type f -name '*.patch' -print0 | grep -zv '{arch}' | xargs -iFILE -0 --no-run-if-empty patch -p1 --forward -iFILE`;
731
        die "Problem applying patches! $!" if $?;
732
    }
733

734
    # apply changed binary files
735
    if (my @modified = `find $tmp/changeset/patches -type f -name '*.modified'`) {
736
        foreach my $mod (@modified) {
737
            chomp $mod;
738
            my $orig = $mod;
739
            $orig =~ s/\.modified$//; # lazy
740
            $orig =~ s!^\Q$tmp\E/changeset/patches/!!;
741
            #print "rsync -p '$mod' '$orig'";
742
            system('rsync','-p',$mod,"./$orig");
743
            die "Problem applying binary changes! $!" if $?;
744
        }
745
    }
746

747
    # bring in new files
748
    system('rsync','-aI','--exclude',$git_dir,
749
		'--exclude','.arch-ids',
750
		'--exclude', '{arch}',
751
		"$tmp/changeset/new-files-archive/",'./');
752

753
    # deleted files are hinted from the commitlog processing
754

755
    rmtree("$tmp/changeset");
756
}
757

758

759
# =for reference
760
# notes: *-files/-directories keys cannot have spaces, they're always
761
# pika-escaped.  Everything after the first newline
762
# A log entry looks like:
763
# Revision: moodle-org--moodle--1.3.3--patch-15
764
# Archive: arch-eduforge@catalyst.net.nz--2004
765
# Creator: Penny Leach <penny@catalyst.net.nz>
766
# Date: Wed May 25 14:15:34 NZST 2005
767
# Standard-date: 2005-05-25 02:15:34 GMT
768
# New-files: lang/de/.arch-ids/block_glossary_random.php.id
769
#     lang/de/.arch-ids/block_html.php.id
770
# New-directories: lang/de/help/questionnaire
771
#     lang/de/help/questionnaire/.arch-ids
772
# Renamed-files: .arch-ids/db_sears.sql.id db/.arch-ids/db_sears.sql.id
773
#    db_sears.sql db/db_sears.sql
774
# Removed-files: lang/be/docs/.arch-ids/release.html.id
775
#     lang/be/docs/.arch-ids/releaseold.html.id
776
# Modified-files: admin/cron.php admin/delete.php
777
#     admin/editor.html backup/lib.php backup/restore.php
778
# New-patches: arch-eduforge@catalyst.net.nz--2004/moodle-org--moodle--1.3.3--patch-15
779
# Summary: Updating to latest from MOODLE_14_STABLE (1.4.5+)
780
#   summary can be multiline with a leading space just like the above fields
781
# Keywords:
782
#
783
# Updating yadda tadda tadda madda
784
sub parselog {
785
    my ($ps, $log) = @_;
786
    my $key = undef;
787

788
    # headers we want that contain filenames:
789
    my %want_headers = (
790
        new_files => 1,
791
        modified_files => 1,
792
        renamed_files => 1,
793
        renamed_directories => 1,
794
        removed_files => 1,
795
        removed_directories => 1,
796
    );
797

798
    chomp (@$log);
799
    while ($_ = shift @$log) {
800
        if (/^Continuation-of:\s*(.*)/) {
801
            $ps->{tag} = $1;
802
            $key = undef;
803
        } elsif (/^Summary:\s*(.*)$/ ) {
804
            # summary can be multiline as long as it has a leading space.
805
	    # we squeeze it onto a single line, though.
806
            $ps->{summary} = [ $1 ];
807
            $key = 'summary';
808
        } elsif (/^Creator: (.*)\s*<([^\>]+)>/) {
809
            $ps->{author} = $1;
810
            $ps->{email} = $2;
811
            $key = undef;
812
        # any *-files or *-directories can be read here:
813
        } elsif (/^([A-Z][a-z\-]+):\s*(.*)$/) {
814
            my $val = $2;
815
            $key = lc $1;
816
            $key =~ tr/-/_/; # too lazy to quote :P
817
            if ($want_headers{$key}) {
818
                push @{$ps->{$key}}, split(/\s+/, $val);
819
            } else {
820
                $key = undef;
821
            }
822
        } elsif (/^$/) {
823
            last; # remainder of @$log that didn't get shifted off is message
824
        } elsif ($key) {
825
            if (/^\s+(.*)$/) {
826
                if ($key eq 'summary') {
827
                    push @{$ps->{$key}}, $1;
828
                } else { # files/directories:
829
                    push @{$ps->{$key}}, split(/\s+/, $1);
830
                }
831
            } else {
832
                $key = undef;
833
            }
834
        }
835
    }
836

837
    # drop leading empty lines from the log message
838
    while (@$log && $log->[0] eq '') {
839
	shift @$log;
840
    }
841
    if (exists $ps->{summary} && @{$ps->{summary}}) {
842
	$ps->{summary} = join(' ', @{$ps->{summary}});
843
    }
844
    elsif (@$log == 0) {
845
	$ps->{summary} = 'empty commit message';
846
    } else {
847
	$ps->{summary} = $log->[0] . '...';
848
    }
849
    $ps->{message} = join("\n",@$log);
850

851
    # skip Arch control files, unescape pika-escaped files
852
    foreach my $k (keys %want_headers) {
853
        next unless (defined $ps->{$k});
854
        my @tmp = ();
855
        foreach my $t (@{$ps->{$k}}) {
856
           next unless length ($t);
857
           next if $t =~ m!\{arch\}/!;
858
           next if $t =~ m!\.arch-ids/!;
859
           # should we skip this?
860
           next if $t =~ m!\.arch-inventory$!;
861
           # tla cat-archive-log will give us filenames with spaces as file\(sp)name - why?
862
           # we can assume that any filename with \ indicates some pika escaping that we want to get rid of.
863
           if ($t =~ /\\/ ){
864
               $t = (safe_pipe_capture($TLA,'escape','--unescaped',$t))[0];
865
           }
866
           push @tmp, $t;
867
        }
868
        $ps->{$k} = \@tmp;
869
    }
870
}
871

872
# write/read a tag
873
sub tag {
874
    my ($tag, $commit) = @_;
875

876
    if ($opt_o) {
877
        $tag =~ s|/|--|g;
878
    } else {
879
	my $patchname = $tag;
880
	$patchname =~ s/.*--//;
881
        $tag = git_branchname ($tag) . '--' . $patchname;
882
    }
883

884
    if ($commit) {
885
        open(C,">","$git_dir/refs/tags/$tag")
886
            or die "Cannot create tag $tag: $!\n";
887
        print C "$commit\n"
888
            or die "Cannot write tag $tag: $!\n";
889
        close(C)
890
            or die "Cannot write tag $tag: $!\n";
891
        print " * Created tag '$tag' on '$commit'\n" if $opt_v;
892
    } else {                    # read
893
        open(C,"<","$git_dir/refs/tags/$tag")
894
            or die "Cannot read tag $tag: $!\n";
895
        $commit = <C>;
896
        chomp $commit;
897
        die "Error reading tag $tag: $!\n" unless length $commit == 40;
898
        close(C)
899
            or die "Cannot read tag $tag: $!\n";
900
        return $commit;
901
    }
902
}
903

904
# write/read a private tag
905
# reads fail softly if the tag isn't there
906
sub ptag {
907
    my ($tag, $commit) = @_;
908

909
    # don't use subdirs for tags yet, it could screw up other porcelains
910
    $tag =~ s|/|,|g;
911

912
    my $tag_file = "$ptag_dir/$tag";
913
    my $tag_branch_dir = dirname($tag_file);
914
    mkpath($tag_branch_dir) unless (-d $tag_branch_dir);
915

916
    if ($commit) {              # write
917
        open(C,">",$tag_file)
918
            or die "Cannot create tag $tag: $!\n";
919
        print C "$commit\n"
920
            or die "Cannot write tag $tag: $!\n";
921
        close(C)
922
            or die "Cannot write tag $tag: $!\n";
923
	$rptags{$commit} = $tag
924
	    unless $tag =~ m/--base-0$/;
925
    } else {                    # read
926
        # if the tag isn't there, return 0
927
        unless ( -s $tag_file) {
928
            return 0;
929
        }
930
        open(C,"<",$tag_file)
931
            or die "Cannot read tag $tag: $!\n";
932
        $commit = <C>;
933
        chomp $commit;
934
        die "Error reading tag $tag: $!\n" unless length $commit == 40;
935
        close(C)
936
            or die "Cannot read tag $tag: $!\n";
937
	unless (defined $rptags{$commit}) {
938
	    $rptags{$commit} = $tag;
939
	}
940
        return $commit;
941
    }
942
}
943

944
sub find_parents {
945
    #
946
    # Identify what branches are merging into me
947
    # and whether we are fully merged
948
    # git-merge-base <headsha> <headsha> should tell
949
    # me what the base of the merge should be
950
    #
951
    my $ps = shift;
952

953
    my %branches; # holds an arrayref per branch
954
                  # the arrayref contains a list of
955
                  # merged patches between the base
956
                  # of the merge and the current head
957

958
    my @parents;  # parents found for this commit
959

960
    # simple loop to split the merges
961
    # per branch
962
    foreach my $merge (@{$ps->{merges}}) {
963
	my $branch = git_branchname($merge);
964
	unless (defined $branches{$branch} ){
965
	    $branches{$branch} = [];
966
	}
967
	push @{$branches{$branch}}, $merge;
968
    }
969

970
    #
971
    # foreach branch find a merge base and walk it to the
972
    # head where we are, collecting the merged patchsets that
973
    # Arch has recorded. Keep that in @have
974
    # Compare that with the commits on the other branch
975
    # between merge-base and the tip of the branch (@need)
976
    # and see if we have a series of consecutive patches
977
    # starting from the merge base. The tip of the series
978
    # of consecutive patches merged is our new parent for
979
    # that branch.
980
    #
981
    foreach my $branch (keys %branches) {
982

983
	# check that we actually know about the branch
984
	next unless -e "$git_dir/refs/heads/$branch";
985

986
	my $mergebase = safe_pipe_capture(qw(git-merge-base), $branch, $ps->{branch});
987
	if ($?) {
988
	    # Don't die here, Arch supports one-way cherry-picking
989
	    # between branches with no common base (or any relationship
990
	    # at all beforehand)
991
	    warn "Cannot find merge base for $branch and $ps->{branch}";
992
	    next;
993
	}
994
	chomp $mergebase;
995

996
	# now walk up to the mergepoint collecting what patches we have
997
	my $branchtip = git_rev_parse($ps->{branch});
998
	my @ancestors = `git-rev-list --topo-order $branchtip ^$mergebase`;
999
	my %have; # collected merges this branch has
1000
	foreach my $merge (@{$ps->{merges}}) {
1001
	    $have{$merge} = 1;
1002
	}
1003
	my %ancestorshave;
1004
	foreach my $par (@ancestors) {
1005
	    $par = commitid2pset($par);
1006
	    if (defined $par->{merges}) {
1007
		foreach my $merge (@{$par->{merges}}) {
1008
		    $ancestorshave{$merge}=1;
1009
		}
1010
	    }
1011
	}
1012
	# print "++++ Merges in $ps->{id} are....\n";
1013
	# my @have = sort keys %have;	print Dumper(\@have);
1014

1015
	# merge what we have with what ancestors have
1016
	%have = (%have, %ancestorshave);
1017

1018
	# see what the remote branch has - these are the merges we
1019
	# will want to have in a consecutive series from the mergebase
1020
	my $otherbranchtip = git_rev_parse($branch);
1021
	my @needraw = `git-rev-list --topo-order $otherbranchtip ^$mergebase`;
1022
	my @need;
1023
	foreach my $needps (@needraw) { 	# get the psets
1024
	    $needps = commitid2pset($needps);
1025
	    # git-rev-list will also
1026
	    # list commits merged in via earlier
1027
	    # merges. we are only interested in commits
1028
	    # from the branch we're looking at
1029
	    if ($branch eq $needps->{branch}) {
1030
		push @need, $needps->{id};
1031
	    }
1032
	}
1033

1034
	# print "++++ Merges from $branch we want are....\n";
1035
	# print Dumper(\@need);
1036

1037
	my $newparent;
1038
	while (my $needed_commit = pop @need) {
1039
	    if ($have{$needed_commit}) {
1040
		$newparent = $needed_commit;
1041
	    } else {
1042
		last; # break out of the while
1043
	    }
1044
	}
1045
	if ($newparent) {
1046
	    push @parents, $newparent;
1047
	}
1048

1049

1050
    } # end foreach branch
1051

1052
    # prune redundant parents
1053
    my %parents;
1054
    foreach my $p (@parents) {
1055
	$parents{$p} = 1;
1056
    }
1057
    foreach my $p (@parents) {
1058
	next unless exists $psets{$p}{merges};
1059
	next unless ref    $psets{$p}{merges};
1060
	my @merges = @{$psets{$p}{merges}};
1061
	foreach my $merge (@merges) {
1062
	    if ($parents{$merge}) {
1063
		delete $parents{$merge};
1064
	    }
1065
	}
1066
    }
1067

1068
    @parents = ();
1069
    foreach (keys %parents) {
1070
        push @parents, '-p', ptag($_);
1071
    }
1072
    return @parents;
1073
}
1074

1075
sub git_rev_parse {
1076
    my $name = shift;
1077
    my $val  = safe_pipe_capture(qw(git-rev-parse), $name);
1078
    die "Error: git-rev-parse $name" if $?;
1079
    chomp $val;
1080
    return $val;
1081
}
1082

1083
# resolve a SHA1 to a known patchset
1084
sub commitid2pset {
1085
    my $commitid = shift;
1086
    chomp $commitid;
1087
    my $name = $rptags{$commitid}
1088
	|| die "Cannot find reverse tag mapping for $commitid";
1089
    $name =~ s|,|/|;
1090
    my $ps   = $psets{$name}
1091
	|| (print Dumper(sort keys %psets)) && die "Cannot find patchset for $name";
1092
    return $ps;
1093
}
1094

1095

1096
# an alternative to `command` that allows input to be passed as an array
1097
# to work around shell problems with weird characters in arguments
1098
sub safe_pipe_capture {
1099
    my @output;
1100
    if (my $pid = open my $child, '-|') {
1101
        @output = (<$child>);
1102
        close $child or die join(' ',@_).": $! $?";
1103
    } else {
1104
	exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
1105
    }
1106
    return wantarray ? @output : join('',@output);
1107
}
1108

1109
# `tla logs -rf -d <dir> | head -n1` or `baz tree-id <dir>`
1110
sub arch_tree_id {
1111
    my $dir = shift;
1112
    chomp( my $ret = (safe_pipe_capture($TLA,'logs','-rf','-d',$dir))[0] );
1113
    return $ret;
1114
}
1115

1116
sub archive_reachable {
1117
    my $archive = shift;
1118
    return 1 if $reachable{$archive};
1119
    return 0 if $unreachable{$archive};
1120

1121
    if (system "$TLA whereis-archive $archive >/dev/null") {
1122
        if ($opt_a && (system($TLA,'register-archive',
1123
                      "http://mirrors.sourcecontrol.net/$archive") == 0)) {
1124
            $reachable{$archive} = 1;
1125
            return 1;
1126
        }
1127
        print STDERR "Archive is unreachable: $archive\n";
1128
        $unreachable{$archive} = 1;
1129
        return 0;
1130
    } else {
1131
        $reachable{$archive} = 1;
1132
        return 1;
1133
    }
1134
}
1135