archimport: Add the accurate changeset applyer
[git] / 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