perl / Git / SVN.pmon commit Merge branch 'tb/connect-ipv6-parse-fix' into maint (8c2ea51)
   1package Git::SVN;
   2use strict;
   3use warnings;
   4use Fcntl qw/:DEFAULT :seek/;
   5use constant rev_map_fmt => 'NH40';
   6use vars qw/$_no_metadata
   7            $_repack $_repack_flags $_use_svm_props $_head
   8            $_use_svnsync_props $no_reuse_existing
   9            $_use_log_author $_add_author_from $_localtime/;
  10use Carp qw/croak/;
  11use File::Path qw/mkpath/;
  12use File::Copy qw/copy/;
  13use IPC::Open3;
  14use Memoize;  # core since 5.8.0, Jul 2002
  15use Memoize::Storable;
  16use POSIX qw(:signal_h);
  17use Time::Local;
  18
  19use Git qw(
  20    command
  21    command_oneline
  22    command_noisy
  23    command_output_pipe
  24    command_close_pipe
  25    get_tz_offset
  26);
  27use Git::SVN::Utils qw(
  28        fatal
  29        can_compress
  30        join_paths
  31        canonicalize_path
  32        canonicalize_url
  33        add_path_to_url
  34);
  35
  36my $can_use_yaml;
  37BEGIN {
  38        $can_use_yaml = eval { require Git::SVN::Memoize::YAML; 1};
  39}
  40
  41our $_follow_parent  = 1;
  42our $_minimize_url   = 'unset';
  43our $default_repo_id = 'svn';
  44our $default_ref_id  = $ENV{GIT_SVN_ID} || 'git-svn';
  45
  46my ($_gc_nr, $_gc_period);
  47
  48# properties that we do not log:
  49my %SKIP_PROP;
  50BEGIN {
  51        %SKIP_PROP = map { $_ => 1 } qw/svn:wc:ra_dav:version-url
  52                                        svn:special svn:executable
  53                                        svn:entry:committed-rev
  54                                        svn:entry:last-author
  55                                        svn:entry:uuid
  56                                        svn:entry:committed-date/;
  57
  58        # some options are read globally, but can be overridden locally
  59        # per [svn-remote "..."] section.  Command-line options will *NOT*
  60        # override options set in an [svn-remote "..."] section
  61        no strict 'refs';
  62        for my $option (qw/follow_parent no_metadata use_svm_props
  63                           use_svnsync_props/) {
  64                my $key = $option;
  65                $key =~ tr/_//d;
  66                my $prop = "-$option";
  67                *$option = sub {
  68                        my ($self) = @_;
  69                        return $self->{$prop} if exists $self->{$prop};
  70                        my $k = "svn-remote.$self->{repo_id}.$key";
  71                        eval { command_oneline(qw/config --get/, $k) };
  72                        if ($@) {
  73                                $self->{$prop} = ${"Git::SVN::_$option"};
  74                        } else {
  75                                my $v = command_oneline(qw/config --bool/,$k);
  76                                $self->{$prop} = $v eq 'false' ? 0 : 1;
  77                        }
  78                        return $self->{$prop};
  79                }
  80        }
  81}
  82
  83
  84my (%LOCKFILES, %INDEX_FILES);
  85END {
  86        unlink keys %LOCKFILES if %LOCKFILES;
  87        unlink keys %INDEX_FILES if %INDEX_FILES;
  88}
  89
  90sub resolve_local_globs {
  91        my ($url, $fetch, $glob_spec) = @_;
  92        return unless defined $glob_spec;
  93        my $ref = $glob_spec->{ref};
  94        my $path = $glob_spec->{path};
  95        foreach (command(qw#for-each-ref --format=%(refname) refs/#)) {
  96                next unless m#^$ref->{regex}$#;
  97                my $p = $1;
  98                my $pathname = desanitize_refname($path->full_path($p));
  99                my $refname = desanitize_refname($ref->full_path($p));
 100                if (my $existing = $fetch->{$pathname}) {
 101                        if ($existing ne $refname) {
 102                                die "Refspec conflict:\n",
 103                                    "existing: $existing\n",
 104                                    " globbed: $refname\n";
 105                        }
 106                        my $u = (::cmt_metadata("$refname"))[0];
 107                        $u =~ s!^\Q$url\E(/|$)!! or die
 108                          "$refname: '$url' not found in '$u'\n";
 109                        if ($pathname ne $u) {
 110                                warn "W: Refspec glob conflict ",
 111                                     "(ref: $refname):\n",
 112                                     "expected path: $pathname\n",
 113                                     "    real path: $u\n",
 114                                     "Continuing ahead with $u\n";
 115                                next;
 116                        }
 117                } else {
 118                        $fetch->{$pathname} = $refname;
 119                }
 120        }
 121}
 122
 123sub parse_revision_argument {
 124        my ($base, $head) = @_;
 125        if (!defined $::_revision || $::_revision eq 'BASE:HEAD') {
 126                return ($base, $head);
 127        }
 128        return ($1, $2) if ($::_revision =~ /^(\d+):(\d+)$/);
 129        return ($::_revision, $::_revision) if ($::_revision =~ /^\d+$/);
 130        return ($head, $head) if ($::_revision eq 'HEAD');
 131        return ($base, $1) if ($::_revision =~ /^BASE:(\d+)$/);
 132        return ($1, $head) if ($::_revision =~ /^(\d+):HEAD$/);
 133        die "revision argument: $::_revision not understood by git-svn\n";
 134}
 135
 136sub fetch_all {
 137        my ($repo_id, $remotes) = @_;
 138        if (ref $repo_id) {
 139                my $gs = $repo_id;
 140                $repo_id = undef;
 141                $repo_id = $gs->{repo_id};
 142        }
 143        $remotes ||= read_all_remotes();
 144        my $remote = $remotes->{$repo_id} or
 145                     die "[svn-remote \"$repo_id\"] unknown\n";
 146        my $fetch = $remote->{fetch};
 147        my $url = $remote->{url} or die "svn-remote.$repo_id.url not defined\n";
 148        my (@gs, @globs);
 149        my $ra = Git::SVN::Ra->new($url);
 150        my $uuid = $ra->get_uuid;
 151        my $head = $ra->get_latest_revnum;
 152
 153        # ignore errors, $head revision may not even exist anymore
 154        eval { $ra->get_log("", $head, 0, 1, 0, 1, sub { $head = $_[1] }) };
 155        warn "W: $@\n" if $@;
 156
 157        my $base = defined $fetch ? $head : 0;
 158
 159        # read the max revs for wildcard expansion (branches/*, tags/*)
 160        foreach my $t (qw/branches tags/) {
 161                defined $remote->{$t} or next;
 162                push @globs, @{$remote->{$t}};
 163
 164                my $max_rev = eval { tmp_config(qw/--int --get/,
 165                                         "svn-remote.$repo_id.${t}-maxRev") };
 166                if (defined $max_rev && ($max_rev < $base)) {
 167                        $base = $max_rev;
 168                } elsif (!defined $max_rev) {
 169                        $base = 0;
 170                }
 171        }
 172
 173        if ($fetch) {
 174                foreach my $p (sort keys %$fetch) {
 175                        my $gs = Git::SVN->new($fetch->{$p}, $repo_id, $p);
 176                        my $lr = $gs->rev_map_max;
 177                        if (defined $lr) {
 178                                $base = $lr if ($lr < $base);
 179                        }
 180                        push @gs, $gs;
 181                }
 182        }
 183
 184        ($base, $head) = parse_revision_argument($base, $head);
 185        $ra->gs_fetch_loop_common($base, $head, \@gs, \@globs);
 186}
 187
 188sub read_all_remotes {
 189        my $r = {};
 190        my $use_svm_props = eval { command_oneline(qw/config --bool
 191            svn.useSvmProps/) };
 192        $use_svm_props = $use_svm_props eq 'true' if $use_svm_props;
 193        my $svn_refspec = qr{\s*(.*?)\s*:\s*(.+?)\s*};
 194        foreach (grep { s/^svn-remote\.// } command(qw/config -l/)) {
 195                if (m!^(.+)\.fetch=$svn_refspec$!) {
 196                        my ($remote, $local_ref, $remote_ref) = ($1, $2, $3);
 197                        die("svn-remote.$remote: remote ref '$remote_ref' "
 198                            . "must start with 'refs/'\n")
 199                                unless $remote_ref =~ m{^refs/};
 200                        $local_ref = uri_decode($local_ref);
 201                        $r->{$remote}->{fetch}->{$local_ref} = $remote_ref;
 202                        $r->{$remote}->{svm} = {} if $use_svm_props;
 203                } elsif (m!^(.+)\.usesvmprops=\s*(.*)\s*$!) {
 204                        $r->{$1}->{svm} = {};
 205                } elsif (m!^(.+)\.url=\s*(.*)\s*$!) {
 206                        $r->{$1}->{url} = canonicalize_url($2);
 207                } elsif (m!^(.+)\.pushurl=\s*(.*)\s*$!) {
 208                        $r->{$1}->{pushurl} = canonicalize_url($2);
 209                } elsif (m!^(.+)\.ignore-refs=\s*(.*)\s*$!) {
 210                        $r->{$1}->{ignore_refs_regex} = $2;
 211                } elsif (m!^(.+)\.(branches|tags)=$svn_refspec$!) {
 212                        my ($remote, $t, $local_ref, $remote_ref) =
 213                                                             ($1, $2, $3, $4);
 214                        die("svn-remote.$remote: remote ref '$remote_ref' ($t) "
 215                            . "must start with 'refs/'\n")
 216                                unless $remote_ref =~ m{^refs/};
 217                        $local_ref = uri_decode($local_ref);
 218
 219                        require Git::SVN::GlobSpec;
 220                        my $rs = {
 221                            t => $t,
 222                            remote => $remote,
 223                            path => Git::SVN::GlobSpec->new($local_ref, 1),
 224                            ref => Git::SVN::GlobSpec->new($remote_ref, 0) };
 225                        if (length($rs->{ref}->{right}) != 0) {
 226                                die "The '*' glob character must be the last ",
 227                                    "character of '$remote_ref'\n";
 228                        }
 229                        push @{ $r->{$remote}->{$t} }, $rs;
 230                }
 231        }
 232
 233        map {
 234                if (defined $r->{$_}->{svm}) {
 235                        my $svm;
 236                        eval {
 237                                my $section = "svn-remote.$_";
 238                                $svm = {
 239                                        source => tmp_config('--get',
 240                                            "$section.svm-source"),
 241                                        replace => tmp_config('--get',
 242                                            "$section.svm-replace"),
 243                                }
 244                        };
 245                        $r->{$_}->{svm} = $svm;
 246                }
 247        } keys %$r;
 248
 249        foreach my $remote (keys %$r) {
 250                foreach ( grep { defined $_ }
 251                          map { $r->{$remote}->{$_} } qw(branches tags) ) {
 252                        foreach my $rs ( @$_ ) {
 253                                $rs->{ignore_refs_regex} =
 254                                    $r->{$remote}->{ignore_refs_regex};
 255                        }
 256                }
 257        }
 258
 259        $r;
 260}
 261
 262sub init_vars {
 263        $_gc_nr = $_gc_period = 1000;
 264        if (defined $_repack || defined $_repack_flags) {
 265               warn "Repack options are obsolete; they have no effect.\n";
 266        }
 267}
 268
 269sub verify_remotes_sanity {
 270        return unless -d $ENV{GIT_DIR};
 271        my %seen;
 272        foreach (command(qw/config -l/)) {
 273                if (m!^svn-remote\.(?:.+)\.fetch=.*:refs/remotes/(\S+)\s*$!) {
 274                        if ($seen{$1}) {
 275                                die "Remote ref refs/remote/$1 is tracked by",
 276                                    "\n  \"$_\"\nand\n  \"$seen{$1}\"\n",
 277                                    "Please resolve this ambiguity in ",
 278                                    "your git configuration file before ",
 279                                    "continuing\n";
 280                        }
 281                        $seen{$1} = $_;
 282                }
 283        }
 284}
 285
 286sub find_existing_remote {
 287        my ($url, $remotes) = @_;
 288        return undef if $no_reuse_existing;
 289        my $existing;
 290        foreach my $repo_id (keys %$remotes) {
 291                my $u = $remotes->{$repo_id}->{url} or next;
 292                next if $u ne $url;
 293                $existing = $repo_id;
 294                last;
 295        }
 296        $existing;
 297}
 298
 299sub init_remote_config {
 300        my ($self, $url, $no_write) = @_;
 301        $url = canonicalize_url($url);
 302        my $r = read_all_remotes();
 303        my $existing = find_existing_remote($url, $r);
 304        if ($existing) {
 305                unless ($no_write) {
 306                        print STDERR "Using existing ",
 307                                     "[svn-remote \"$existing\"]\n";
 308                }
 309                $self->{repo_id} = $existing;
 310        } elsif ($_minimize_url) {
 311                my $min_url = Git::SVN::Ra->new($url)->minimize_url;
 312                $existing = find_existing_remote($min_url, $r);
 313                if ($existing) {
 314                        unless ($no_write) {
 315                                print STDERR "Using existing ",
 316                                             "[svn-remote \"$existing\"]\n";
 317                        }
 318                        $self->{repo_id} = $existing;
 319                }
 320                if ($min_url ne $url) {
 321                        unless ($no_write) {
 322                                print STDERR "Using higher level of URL: ",
 323                                             "$url => $min_url\n";
 324                        }
 325                        my $old_path = $self->path;
 326                        $url =~ s!^\Q$min_url\E(/|$)!!;
 327                        $url = join_paths($url, $old_path);
 328                        $self->path($url);
 329                        $url = $min_url;
 330                }
 331        }
 332        my $orig_url;
 333        if (!$existing) {
 334                # verify that we aren't overwriting anything:
 335                $orig_url = eval {
 336                        command_oneline('config', '--get',
 337                                        "svn-remote.$self->{repo_id}.url")
 338                };
 339                if ($orig_url && ($orig_url ne $url)) {
 340                        die "svn-remote.$self->{repo_id}.url already set: ",
 341                            "$orig_url\nwanted to set to: $url\n";
 342                }
 343        }
 344        my ($xrepo_id, $xpath) = find_ref($self->refname);
 345        if (!$no_write && defined $xpath) {
 346                die "svn-remote.$xrepo_id.fetch already set to track ",
 347                    "$xpath:", $self->refname, "\n";
 348        }
 349        unless ($no_write) {
 350                command_noisy('config',
 351                              "svn-remote.$self->{repo_id}.url", $url);
 352                my $path = $self->path;
 353                $path =~ s{^/}{};
 354                $path =~ s{%([0-9A-F]{2})}{chr hex($1)}ieg;
 355                $self->path($path);
 356                command_noisy('config', '--add',
 357                              "svn-remote.$self->{repo_id}.fetch",
 358                              $self->path.":".$self->refname);
 359        }
 360        $self->url($url);
 361}
 362
 363sub find_by_url { # repos_root and, path are optional
 364        my ($class, $full_url, $repos_root, $path) = @_;
 365
 366        $full_url = canonicalize_url($full_url);
 367
 368        return undef unless defined $full_url;
 369        remove_username($full_url);
 370        remove_username($repos_root) if defined $repos_root;
 371        my $remotes = read_all_remotes();
 372        if (defined $full_url && defined $repos_root && !defined $path) {
 373                $path = $full_url;
 374                $path =~ s#^\Q$repos_root\E(?:/|$)##;
 375        }
 376        foreach my $repo_id (keys %$remotes) {
 377                my $u = $remotes->{$repo_id}->{url} or next;
 378                remove_username($u);
 379                next if defined $repos_root && $repos_root ne $u;
 380
 381                my $fetch = $remotes->{$repo_id}->{fetch} || {};
 382                foreach my $t (qw/branches tags/) {
 383                        foreach my $globspec (@{$remotes->{$repo_id}->{$t}}) {
 384                                resolve_local_globs($u, $fetch, $globspec);
 385                        }
 386                }
 387                my $p = $path;
 388                my $rwr = rewrite_root({repo_id => $repo_id});
 389                my $svm = $remotes->{$repo_id}->{svm}
 390                        if defined $remotes->{$repo_id}->{svm};
 391                unless (defined $p) {
 392                        $p = $full_url;
 393                        my $z = $u;
 394                        my $prefix = '';
 395                        if ($rwr) {
 396                                $z = $rwr;
 397                                remove_username($z);
 398                        } elsif (defined $svm) {
 399                                $z = $svm->{source};
 400                                $prefix = $svm->{replace};
 401                                $prefix =~ s#^\Q$u\E(?:/|$)##;
 402                                $prefix =~ s#/$##;
 403                        }
 404                        $p =~ s#^\Q$z\E(?:/|$)#$prefix# or next;
 405                }
 406
 407                # remote fetch paths are not URI escaped.  Decode ours
 408                # so they match
 409                $p = uri_decode($p);
 410
 411                foreach my $f (keys %$fetch) {
 412                        next if $f ne $p;
 413                        return Git::SVN->new($fetch->{$f}, $repo_id, $f);
 414                }
 415        }
 416        undef;
 417}
 418
 419sub init {
 420        my ($class, $url, $path, $repo_id, $ref_id, $no_write) = @_;
 421        my $self = _new($class, $repo_id, $ref_id, $path);
 422        if (defined $url) {
 423                $self->init_remote_config($url, $no_write);
 424        }
 425        $self;
 426}
 427
 428sub find_ref {
 429        my ($ref_id) = @_;
 430        foreach (command(qw/config -l/)) {
 431                next unless m!^svn-remote\.(.+)\.fetch=
 432                              \s*(.*?)\s*:\s*(.+?)\s*$!x;
 433                my ($repo_id, $path, $ref) = ($1, $2, $3);
 434                if ($ref eq $ref_id) {
 435                        $path = '' if ($path =~ m#^\./?#);
 436                        return ($repo_id, $path);
 437                }
 438        }
 439        (undef, undef, undef);
 440}
 441
 442sub new {
 443        my ($class, $ref_id, $repo_id, $path) = @_;
 444        if (defined $ref_id && !defined $repo_id && !defined $path) {
 445                ($repo_id, $path) = find_ref($ref_id);
 446                if (!defined $repo_id) {
 447                        die "Could not find a \"svn-remote.*.fetch\" key ",
 448                            "in the repository configuration matching: ",
 449                            "$ref_id\n";
 450                }
 451        }
 452        my $self = _new($class, $repo_id, $ref_id, $path);
 453        if (!defined $self->path || !length $self->path) {
 454                my $fetch = command_oneline('config', '--get',
 455                                            "svn-remote.$repo_id.fetch",
 456                                            ":$ref_id\$") or
 457                     die "Failed to read \"svn-remote.$repo_id.fetch\" ",
 458                         "\":$ref_id\$\" in config\n";
 459                my($path) = split(/\s*:\s*/, $fetch);
 460                $self->path($path);
 461        }
 462        {
 463                my $path = $self->path;
 464                $path =~ s{\A/}{};
 465                $path =~ s{/\z}{};
 466                $self->path($path);
 467        }
 468        my $url = command_oneline('config', '--get',
 469                                  "svn-remote.$repo_id.url") or
 470                  die "Failed to read \"svn-remote.$repo_id.url\" in config\n";
 471        $self->url($url);
 472        $self->{pushurl} = eval { command_oneline('config', '--get',
 473                                  "svn-remote.$repo_id.pushurl") };
 474        $self->rebuild;
 475        $self;
 476}
 477
 478sub refname {
 479        my ($refname) = $_[0]->{ref_id} ;
 480
 481        # It cannot end with a slash /, we'll throw up on this because
 482        # SVN can't have directories with a slash in their name, either:
 483        if ($refname =~ m{/$}) {
 484                die "ref: '$refname' ends with a trailing slash; this is ",
 485                    "not permitted by git or Subversion\n";
 486        }
 487
 488        # It cannot have ASCII control character space, tilde ~, caret ^,
 489        # colon :, question-mark ?, asterisk *, space, or open bracket [
 490        # anywhere.
 491        #
 492        # Additionally, % must be escaped because it is used for escaping
 493        # and we want our escaped refname to be reversible
 494        $refname =~ s{([ \%~\^:\?\*\[\t])}{sprintf('%%%02X',ord($1))}eg;
 495
 496        # no slash-separated component can begin with a dot .
 497        # /.* becomes /%2E*
 498        $refname =~ s{/\.}{/%2E}g;
 499
 500        # It cannot have two consecutive dots .. anywhere
 501        # .. becomes %2E%2E
 502        $refname =~ s{\.\.}{%2E%2E}g;
 503
 504        # trailing dots and .lock are not allowed
 505        # .$ becomes %2E and .lock becomes %2Elock
 506        $refname =~ s{\.(?=$|lock$)}{%2E};
 507
 508        # the sequence @{ is used to access the reflog
 509        # @{ becomes %40{
 510        $refname =~ s{\@\{}{%40\{}g;
 511
 512        return $refname;
 513}
 514
 515sub desanitize_refname {
 516        my ($refname) = @_;
 517        $refname =~ s{%(?:([0-9A-F]{2}))}{chr hex($1)}eg;
 518        return $refname;
 519}
 520
 521sub svm_uuid {
 522        my ($self) = @_;
 523        return $self->{svm}->{uuid} if $self->svm;
 524        $self->ra;
 525        unless ($self->{svm}) {
 526                die "SVM UUID not cached, and reading remotely failed\n";
 527        }
 528        $self->{svm}->{uuid};
 529}
 530
 531sub svm {
 532        my ($self) = @_;
 533        return $self->{svm} if $self->{svm};
 534        my $svm;
 535        # see if we have it in our config, first:
 536        eval {
 537                my $section = "svn-remote.$self->{repo_id}";
 538                $svm = {
 539                  source => tmp_config('--get', "$section.svm-source"),
 540                  uuid => tmp_config('--get', "$section.svm-uuid"),
 541                  replace => tmp_config('--get', "$section.svm-replace"),
 542                }
 543        };
 544        if ($svm && $svm->{source} && $svm->{uuid} && $svm->{replace}) {
 545                $self->{svm} = $svm;
 546        }
 547        $self->{svm};
 548}
 549
 550sub _set_svm_vars {
 551        my ($self, $ra) = @_;
 552        return $ra if $self->svm;
 553
 554        my @err = ( "useSvmProps set, but failed to read SVM properties\n",
 555                    "(svm:source, svm:uuid) ",
 556                    "from the following URLs:\n" );
 557        sub read_svm_props {
 558                my ($self, $ra, $path, $r) = @_;
 559                my $props = ($ra->get_dir($path, $r))[2];
 560                my $src = $props->{'svm:source'};
 561                my $uuid = $props->{'svm:uuid'};
 562                return undef if (!$src || !$uuid);
 563
 564                chomp($src, $uuid);
 565
 566                $uuid =~ m{^[0-9a-f\-]{30,}$}i
 567                    or die "doesn't look right - svm:uuid is '$uuid'\n";
 568
 569                # the '!' is used to mark the repos_root!/relative/path
 570                $src =~ s{/?!/?}{/};
 571                $src =~ s{/+$}{}; # no trailing slashes please
 572                # username is of no interest
 573                $src =~ s{(^[a-z\+]*://)[^/@]*@}{$1};
 574
 575                my $replace = add_path_to_url($ra->url, $path);
 576
 577                my $section = "svn-remote.$self->{repo_id}";
 578                tmp_config("$section.svm-source", $src);
 579                tmp_config("$section.svm-replace", $replace);
 580                tmp_config("$section.svm-uuid", $uuid);
 581                $self->{svm} = {
 582                        source => $src,
 583                        uuid => $uuid,
 584                        replace => $replace
 585                };
 586        }
 587
 588        my $r = $ra->get_latest_revnum;
 589        my $path = $self->path;
 590        my %tried;
 591        while (length $path) {
 592                my $try = add_path_to_url($self->url, $path);
 593                unless ($tried{$try}) {
 594                        return $ra if $self->read_svm_props($ra, $path, $r);
 595                        $tried{$try} = 1;
 596                }
 597                $path =~ s#/?[^/]+$##;
 598        }
 599        die "Path: '$path' should be ''\n" if $path ne '';
 600        return $ra if $self->read_svm_props($ra, $path, $r);
 601        $tried{ add_path_to_url($self->url, $path) } = 1;
 602
 603        if ($ra->{repos_root} eq $self->url) {
 604                die @err, (map { "  $_\n" } keys %tried), "\n";
 605        }
 606
 607        # nope, make sure we're connected to the repository root:
 608        my $ok;
 609        my @tried_b;
 610        $path = $ra->{svn_path};
 611        $ra = Git::SVN::Ra->new($ra->{repos_root});
 612        while (length $path) {
 613                my $try = add_path_to_url($ra->url, $path);
 614                unless ($tried{$try}) {
 615                        $ok = $self->read_svm_props($ra, $path, $r);
 616                        last if $ok;
 617                        $tried{$try} = 1;
 618                }
 619                $path =~ s#/?[^/]+$##;
 620        }
 621        die "Path: '$path' should be ''\n" if $path ne '';
 622        $ok ||= $self->read_svm_props($ra, $path, $r);
 623        $tried{ add_path_to_url($ra->url, $path) } = 1;
 624        if (!$ok) {
 625                die @err, (map { "  $_\n" } keys %tried), "\n";
 626        }
 627        Git::SVN::Ra->new($self->url);
 628}
 629
 630sub svnsync {
 631        my ($self) = @_;
 632        return $self->{svnsync} if $self->{svnsync};
 633
 634        if ($self->no_metadata) {
 635                die "Can't have both 'noMetadata' and ",
 636                    "'useSvnsyncProps' options set!\n";
 637        }
 638        if ($self->rewrite_root) {
 639                die "Can't have both 'useSvnsyncProps' and 'rewriteRoot' ",
 640                    "options set!\n";
 641        }
 642        if ($self->rewrite_uuid) {
 643                die "Can't have both 'useSvnsyncProps' and 'rewriteUUID' ",
 644                    "options set!\n";
 645        }
 646
 647        my $svnsync;
 648        # see if we have it in our config, first:
 649        eval {
 650                my $section = "svn-remote.$self->{repo_id}";
 651
 652                my $url = tmp_config('--get', "$section.svnsync-url");
 653                ($url) = ($url =~ m{^([a-z\+]+://\S+)$}) or
 654                   die "doesn't look right - svn:sync-from-url is '$url'\n";
 655
 656                my $uuid = tmp_config('--get', "$section.svnsync-uuid");
 657                ($uuid) = ($uuid =~ m{^([0-9a-f\-]{30,})$}i) or
 658                   die "doesn't look right - svn:sync-from-uuid is '$uuid'\n";
 659
 660                $svnsync = { url => $url, uuid => $uuid }
 661        };
 662        if ($svnsync && $svnsync->{url} && $svnsync->{uuid}) {
 663                return $self->{svnsync} = $svnsync;
 664        }
 665
 666        my $err = "useSvnsyncProps set, but failed to read " .
 667                  "svnsync property: svn:sync-from-";
 668        my $rp = $self->ra->rev_proplist(0);
 669
 670        my $url = $rp->{'svn:sync-from-url'} or die $err . "url\n";
 671        ($url) = ($url =~ m{^([a-z\+]+://\S+)$}) or
 672                   die "doesn't look right - svn:sync-from-url is '$url'\n";
 673
 674        my $uuid = $rp->{'svn:sync-from-uuid'} or die $err . "uuid\n";
 675        ($uuid) = ($uuid =~ m{^([0-9a-f\-]{30,})$}i) or
 676                   die "doesn't look right - svn:sync-from-uuid is '$uuid'\n";
 677
 678        my $section = "svn-remote.$self->{repo_id}";
 679        tmp_config('--add', "$section.svnsync-uuid", $uuid);
 680        tmp_config('--add', "$section.svnsync-url", $url);
 681        return $self->{svnsync} = { url => $url, uuid => $uuid };
 682}
 683
 684# this allows us to memoize our SVN::Ra UUID locally and avoid a
 685# remote lookup (useful for 'git svn log').
 686sub ra_uuid {
 687        my ($self) = @_;
 688        unless ($self->{ra_uuid}) {
 689                my $key = "svn-remote.$self->{repo_id}.uuid";
 690                my $uuid = eval { tmp_config('--get', $key) };
 691                if (!$@ && $uuid && $uuid =~ /^([a-f\d\-]{30,})$/i) {
 692                        $self->{ra_uuid} = $uuid;
 693                } else {
 694                        die "ra_uuid called without URL\n" unless $self->url;
 695                        $self->{ra_uuid} = $self->ra->get_uuid;
 696                        tmp_config('--add', $key, $self->{ra_uuid});
 697                }
 698        }
 699        $self->{ra_uuid};
 700}
 701
 702sub _set_repos_root {
 703        my ($self, $repos_root) = @_;
 704        my $k = "svn-remote.$self->{repo_id}.reposRoot";
 705        $repos_root ||= $self->ra->{repos_root};
 706        tmp_config($k, $repos_root);
 707        $repos_root;
 708}
 709
 710sub repos_root {
 711        my ($self) = @_;
 712        my $k = "svn-remote.$self->{repo_id}.reposRoot";
 713        eval { tmp_config('--get', $k) } || $self->_set_repos_root;
 714}
 715
 716sub ra {
 717        my ($self) = shift;
 718        my $ra = Git::SVN::Ra->new($self->url);
 719        $self->_set_repos_root($ra->{repos_root});
 720        if ($self->use_svm_props && !$self->{svm}) {
 721                if ($self->no_metadata) {
 722                        die "Can't have both 'noMetadata' and ",
 723                            "'useSvmProps' options set!\n";
 724                } elsif ($self->use_svnsync_props) {
 725                        die "Can't have both 'useSvnsyncProps' and ",
 726                            "'useSvmProps' options set!\n";
 727                }
 728                $ra = $self->_set_svm_vars($ra);
 729                $self->{-want_revprops} = 1;
 730        }
 731        $ra;
 732}
 733
 734# prop_walk(PATH, REV, SUB)
 735# -------------------------
 736# Recursively traverse PATH at revision REV and invoke SUB for each
 737# directory that contains a SVN property.  SUB will be invoked as
 738# follows:  &SUB(gs, path, props);  where `gs' is this instance of
 739# Git::SVN, `path' the path to the directory where the properties
 740# `props' were found.  The `path' will be relative to point of checkout,
 741# that is, if url://repo/trunk is the current Git branch, and that
 742# directory contains a sub-directory `d', SUB will be invoked with `/d/'
 743# as `path' (note the trailing `/').
 744sub prop_walk {
 745        my ($self, $path, $rev, $sub) = @_;
 746
 747        $path =~ s#^/##;
 748        my ($dirent, undef, $props) = $self->ra->get_dir($path, $rev);
 749        $path =~ s#^/*#/#g;
 750        my $p = $path;
 751        # Strip the irrelevant part of the path.
 752        $p =~ s#^/+\Q@{[$self->path]}\E(/|$)#/#;
 753        # Ensure the path is terminated by a `/'.
 754        $p =~ s#/*$#/#;
 755
 756        # The properties contain all the internal SVN stuff nobody
 757        # (usually) cares about.
 758        my $interesting_props = 0;
 759        foreach (keys %{$props}) {
 760                # If it doesn't start with `svn:', it must be a
 761                # user-defined property.
 762                ++$interesting_props and next if $_ !~ /^svn:/;
 763                # FIXME: Fragile, if SVN adds new public properties,
 764                # this needs to be updated.
 765                ++$interesting_props if /^svn:(?:ignore|keywords|executable
 766                                                 |eol-style|mime-type
 767                                                 |externals|needs-lock)$/x;
 768        }
 769        &$sub($self, $p, $props) if $interesting_props;
 770
 771        foreach (sort keys %$dirent) {
 772                next if $dirent->{$_}->{kind} != $SVN::Node::dir;
 773                $self->prop_walk($self->path . $p . $_, $rev, $sub);
 774        }
 775}
 776
 777sub last_rev { ($_[0]->last_rev_commit)[0] }
 778sub last_commit { ($_[0]->last_rev_commit)[1] }
 779
 780# returns the newest SVN revision number and newest commit SHA1
 781sub last_rev_commit {
 782        my ($self) = @_;
 783        if (defined $self->{last_rev} && defined $self->{last_commit}) {
 784                return ($self->{last_rev}, $self->{last_commit});
 785        }
 786        my $c = ::verify_ref($self->refname.'^0');
 787        if ($c && !$self->use_svm_props && !$self->no_metadata) {
 788                my $rev = (::cmt_metadata($c))[1];
 789                if (defined $rev) {
 790                        ($self->{last_rev}, $self->{last_commit}) = ($rev, $c);
 791                        return ($rev, $c);
 792                }
 793        }
 794        my $map_path = $self->map_path;
 795        unless (-e $map_path) {
 796                ($self->{last_rev}, $self->{last_commit}) = (undef, undef);
 797                return (undef, undef);
 798        }
 799        my ($rev, $commit) = $self->rev_map_max(1);
 800        ($self->{last_rev}, $self->{last_commit}) = ($rev, $commit);
 801        return ($rev, $commit);
 802}
 803
 804sub get_fetch_range {
 805        my ($self, $min, $max) = @_;
 806        $max ||= $self->ra->get_latest_revnum;
 807        $min ||= $self->rev_map_max;
 808        (++$min, $max);
 809}
 810
 811sub tmp_config {
 812        my (@args) = @_;
 813        my $old_def_config = "$ENV{GIT_DIR}/svn/config";
 814        my $config = "$ENV{GIT_DIR}/svn/.metadata";
 815        if (! -f $config && -f $old_def_config) {
 816                rename $old_def_config, $config or
 817                       die "Failed rename $old_def_config => $config: $!\n";
 818        }
 819        my $old_config = $ENV{GIT_CONFIG};
 820        $ENV{GIT_CONFIG} = $config;
 821        $@ = undef;
 822        my @ret = eval {
 823                unless (-f $config) {
 824                        mkfile($config);
 825                        open my $fh, '>', $config or
 826                            die "Can't open $config: $!\n";
 827                        print $fh "; This file is used internally by ",
 828                                  "git-svn\n" or die
 829                                  "Couldn't write to $config: $!\n";
 830                        print $fh "; You should not have to edit it\n" or
 831                              die "Couldn't write to $config: $!\n";
 832                        close $fh or die "Couldn't close $config: $!\n";
 833                }
 834                command('config', @args);
 835        };
 836        my $err = $@;
 837        if (defined $old_config) {
 838                $ENV{GIT_CONFIG} = $old_config;
 839        } else {
 840                delete $ENV{GIT_CONFIG};
 841        }
 842        die $err if $err;
 843        wantarray ? @ret : $ret[0];
 844}
 845
 846sub tmp_index_do {
 847        my ($self, $sub) = @_;
 848        my $old_index = $ENV{GIT_INDEX_FILE};
 849        $ENV{GIT_INDEX_FILE} = $self->{index};
 850        $@ = undef;
 851        my @ret = eval {
 852                my ($dir, $base) = ($self->{index} =~ m#^(.*?)/?([^/]+)$#);
 853                mkpath([$dir]) unless -d $dir;
 854                &$sub;
 855        };
 856        my $err = $@;
 857        if (defined $old_index) {
 858                $ENV{GIT_INDEX_FILE} = $old_index;
 859        } else {
 860                delete $ENV{GIT_INDEX_FILE};
 861        }
 862        die $err if $err;
 863        wantarray ? @ret : $ret[0];
 864}
 865
 866sub assert_index_clean {
 867        my ($self, $treeish) = @_;
 868
 869        $self->tmp_index_do(sub {
 870                command_noisy('read-tree', $treeish) unless -e $self->{index};
 871                my $x = command_oneline('write-tree');
 872                my ($y) = (command(qw/cat-file commit/, $treeish) =~
 873                           /^tree ($::sha1)/mo);
 874                return if $y eq $x;
 875
 876                warn "Index mismatch: $y != $x\nrereading $treeish\n";
 877                unlink $self->{index} or die "unlink $self->{index}: $!\n";
 878                command_noisy('read-tree', $treeish);
 879                $x = command_oneline('write-tree');
 880                if ($y ne $x) {
 881                        fatal "trees ($treeish) $y != $x\n",
 882                              "Something is seriously wrong...";
 883                }
 884        });
 885}
 886
 887sub get_commit_parents {
 888        my ($self, $log_entry) = @_;
 889        my (%seen, @ret, @tmp);
 890        # legacy support for 'set-tree'; this is only used by set_tree_cb:
 891        if (my $ip = $self->{inject_parents}) {
 892                if (my $commit = delete $ip->{$log_entry->{revision}}) {
 893                        push @tmp, $commit;
 894                }
 895        }
 896        if (my $cur = ::verify_ref($self->refname.'^0')) {
 897                push @tmp, $cur;
 898        }
 899        if (my $ipd = $self->{inject_parents_dcommit}) {
 900                if (my $commit = delete $ipd->{$log_entry->{revision}}) {
 901                        push @tmp, @$commit;
 902                }
 903        }
 904        push @tmp, $_ foreach (@{$log_entry->{parents}}, @tmp);
 905        while (my $p = shift @tmp) {
 906                next if $seen{$p};
 907                $seen{$p} = 1;
 908                push @ret, $p;
 909        }
 910        @ret;
 911}
 912
 913sub rewrite_root {
 914        my ($self) = @_;
 915        return $self->{-rewrite_root} if exists $self->{-rewrite_root};
 916        my $k = "svn-remote.$self->{repo_id}.rewriteRoot";
 917        my $rwr = eval { command_oneline(qw/config --get/, $k) };
 918        if ($rwr) {
 919                $rwr =~ s#/+$##;
 920                if ($rwr !~ m#^[a-z\+]+://#) {
 921                        die "$rwr is not a valid URL (key: $k)\n";
 922                }
 923        }
 924        $self->{-rewrite_root} = $rwr;
 925}
 926
 927sub rewrite_uuid {
 928        my ($self) = @_;
 929        return $self->{-rewrite_uuid} if exists $self->{-rewrite_uuid};
 930        my $k = "svn-remote.$self->{repo_id}.rewriteUUID";
 931        my $rwid = eval { command_oneline(qw/config --get/, $k) };
 932        if ($rwid) {
 933                $rwid =~ s#/+$##;
 934                if ($rwid !~ m#^[a-f0-9]{8}-(?:[a-f0-9]{4}-){3}[a-f0-9]{12}$#) {
 935                        die "$rwid is not a valid UUID (key: $k)\n";
 936                }
 937        }
 938        $self->{-rewrite_uuid} = $rwid;
 939}
 940
 941sub metadata_url {
 942        my ($self) = @_;
 943        my $url = $self->rewrite_root || $self->url;
 944        return canonicalize_url( add_path_to_url( $url, $self->path ) );
 945}
 946
 947sub full_url {
 948        my ($self) = @_;
 949        return canonicalize_url( add_path_to_url( $self->url, $self->path ) );
 950}
 951
 952sub full_pushurl {
 953        my ($self) = @_;
 954        if ($self->{pushurl}) {
 955                return canonicalize_url( add_path_to_url( $self->{pushurl}, $self->path ) );
 956        } else {
 957                return $self->full_url;
 958        }
 959}
 960
 961sub set_commit_header_env {
 962        my ($log_entry) = @_;
 963        my %env;
 964        foreach my $ned (qw/NAME EMAIL DATE/) {
 965                foreach my $ac (qw/AUTHOR COMMITTER/) {
 966                        $env{"GIT_${ac}_${ned}"} = $ENV{"GIT_${ac}_${ned}"};
 967                }
 968        }
 969
 970        $ENV{GIT_AUTHOR_NAME} = $log_entry->{name};
 971        $ENV{GIT_AUTHOR_EMAIL} = $log_entry->{email};
 972        $ENV{GIT_AUTHOR_DATE} = $ENV{GIT_COMMITTER_DATE} = $log_entry->{date};
 973
 974        $ENV{GIT_COMMITTER_NAME} = (defined $log_entry->{commit_name})
 975                                                ? $log_entry->{commit_name}
 976                                                : $log_entry->{name};
 977        $ENV{GIT_COMMITTER_EMAIL} = (defined $log_entry->{commit_email})
 978                                                ? $log_entry->{commit_email}
 979                                                : $log_entry->{email};
 980        \%env;
 981}
 982
 983sub restore_commit_header_env {
 984        my ($env) = @_;
 985        foreach my $ned (qw/NAME EMAIL DATE/) {
 986                foreach my $ac (qw/AUTHOR COMMITTER/) {
 987                        my $k = "GIT_${ac}_${ned}";
 988                        if (defined $env->{$k}) {
 989                                $ENV{$k} = $env->{$k};
 990                        } else {
 991                                delete $ENV{$k};
 992                        }
 993                }
 994        }
 995}
 996
 997sub gc {
 998        command_noisy('gc', '--auto');
 999};
1000
1001sub do_git_commit {
1002        my ($self, $log_entry) = @_;
1003        my $lr = $self->last_rev;
1004        if (defined $lr && $lr >= $log_entry->{revision}) {
1005                die "Last fetched revision of ", $self->refname,
1006                    " was r$lr, but we are about to fetch: ",
1007                    "r$log_entry->{revision}!\n";
1008        }
1009        if (my $c = $self->rev_map_get($log_entry->{revision})) {
1010                croak "$log_entry->{revision} = $c already exists! ",
1011                      "Why are we refetching it?\n";
1012        }
1013        my $old_env = set_commit_header_env($log_entry);
1014        my $tree = $log_entry->{tree};
1015        if (!defined $tree) {
1016                $tree = $self->tmp_index_do(sub {
1017                                            command_oneline('write-tree') });
1018        }
1019        die "Tree is not a valid sha1: $tree\n" if $tree !~ /^$::sha1$/o;
1020
1021        my @exec = ('git', 'commit-tree', $tree);
1022        foreach ($self->get_commit_parents($log_entry)) {
1023                push @exec, '-p', $_;
1024        }
1025        defined(my $pid = open3(my $msg_fh, my $out_fh, '>&STDERR', @exec))
1026                                                                   or croak $!;
1027        binmode $msg_fh;
1028
1029        # we always get UTF-8 from SVN, but we may want our commits in
1030        # a different encoding.
1031        if (my $enc = Git::config('i18n.commitencoding')) {
1032                require Encode;
1033                Encode::from_to($log_entry->{log}, 'UTF-8', $enc);
1034        }
1035        print $msg_fh $log_entry->{log} or croak $!;
1036        restore_commit_header_env($old_env);
1037        unless ($self->no_metadata) {
1038                print $msg_fh "\ngit-svn-id: $log_entry->{metadata}\n"
1039                              or croak $!;
1040        }
1041        $msg_fh->flush == 0 or croak $!;
1042        close $msg_fh or croak $!;
1043        chomp(my $commit = do { local $/; <$out_fh> });
1044        close $out_fh or croak $!;
1045        waitpid $pid, 0;
1046        croak $? if $?;
1047        if ($commit !~ /^$::sha1$/o) {
1048                die "Failed to commit, invalid sha1: $commit\n";
1049        }
1050
1051        $self->rev_map_set($log_entry->{revision}, $commit, 1);
1052
1053        $self->{last_rev} = $log_entry->{revision};
1054        $self->{last_commit} = $commit;
1055        print "r$log_entry->{revision}" unless $::_q > 1;
1056        if (defined $log_entry->{svm_revision}) {
1057                 print " (\@$log_entry->{svm_revision})" unless $::_q > 1;
1058                 $self->rev_map_set($log_entry->{svm_revision}, $commit,
1059                                   0, $self->svm_uuid);
1060        }
1061        print " = $commit ($self->{ref_id})\n" unless $::_q > 1;
1062        if (--$_gc_nr == 0) {
1063                $_gc_nr = $_gc_period;
1064                gc();
1065        }
1066        return $commit;
1067}
1068
1069sub match_paths {
1070        my ($self, $paths, $r) = @_;
1071        return 1 if $self->path eq '';
1072        if (my $path = $paths->{"/".$self->path}) {
1073                return ($path->{action} eq 'D') ? 0 : 1;
1074        }
1075        $self->{path_regex} ||= qr{^/\Q@{[$self->path]}\E/};
1076        if (grep /$self->{path_regex}/, keys %$paths) {
1077                return 1;
1078        }
1079        my $c = '';
1080        foreach (split m#/#, $self->path) {
1081                $c .= "/$_";
1082                next unless ($paths->{$c} &&
1083                             ($paths->{$c}->{action} =~ /^[AR]$/));
1084                if ($self->ra->check_path($self->path, $r) ==
1085                    $SVN::Node::dir) {
1086                        return 1;
1087                }
1088        }
1089        return 0;
1090}
1091
1092sub find_parent_branch {
1093        my ($self, $paths, $rev) = @_;
1094        return undef unless $self->follow_parent;
1095        unless (defined $paths) {
1096                my $err_handler = $SVN::Error::handler;
1097                $SVN::Error::handler = \&Git::SVN::Ra::skip_unknown_revs;
1098                $self->ra->get_log([$self->path], $rev, $rev, 0, 1, 1,
1099                                   sub { $paths = $_[0] });
1100                $SVN::Error::handler = $err_handler;
1101        }
1102        return undef unless defined $paths;
1103
1104        # look for a parent from another branch:
1105        my @b_path_components = split m#/#, $self->path;
1106        my @a_path_components;
1107        my $i;
1108        while (@b_path_components) {
1109                $i = $paths->{'/'.join('/', @b_path_components)};
1110                last if $i && defined $i->{copyfrom_path};
1111                unshift(@a_path_components, pop(@b_path_components));
1112        }
1113        return undef unless defined $i && defined $i->{copyfrom_path};
1114        my $branch_from = $i->{copyfrom_path};
1115        if (@a_path_components) {
1116                print STDERR "branch_from: $branch_from => ";
1117                $branch_from .= '/'.join('/', @a_path_components);
1118                print STDERR $branch_from, "\n";
1119        }
1120        my $r = $i->{copyfrom_rev};
1121        my $repos_root = $self->ra->{repos_root};
1122        my $url = $self->ra->url;
1123        my $new_url = canonicalize_url( add_path_to_url( $url, $branch_from ) );
1124        print STDERR  "Found possible branch point: ",
1125                      "$new_url => ", $self->full_url, ", $r\n"
1126                      unless $::_q > 1;
1127        $branch_from =~ s#^/##;
1128        my $gs = $self->other_gs($new_url, $url,
1129                                 $branch_from, $r, $self->{ref_id});
1130        my ($r0, $parent) = $gs->find_rev_before($r, 1);
1131        {
1132                my ($base, $head);
1133                if (!defined $r0 || !defined $parent) {
1134                        ($base, $head) = parse_revision_argument(0, $r);
1135                } else {
1136                        if ($r0 < $r) {
1137                                $gs->ra->get_log([$gs->path], $r0 + 1, $r, 1,
1138                                        0, 1, sub { $base = $_[1] - 1 });
1139                        }
1140                }
1141                if (defined $base && $base <= $r) {
1142                        $gs->fetch($base, $r);
1143                }
1144                ($r0, $parent) = $gs->find_rev_before($r, 1);
1145        }
1146        if (defined $r0 && defined $parent) {
1147                print STDERR "Found branch parent: ($self->{ref_id}) $parent\n"
1148                             unless $::_q > 1;
1149                my $ed;
1150                if ($self->ra->can_do_switch) {
1151                        $self->assert_index_clean($parent);
1152                        print STDERR "Following parent with do_switch\n"
1153                                     unless $::_q > 1;
1154                        # do_switch works with svn/trunk >= r22312, but that
1155                        # is not included with SVN 1.4.3 (the latest version
1156                        # at the moment), so we can't rely on it
1157                        $self->{last_rev} = $r0;
1158                        $self->{last_commit} = $parent;
1159                        $ed = Git::SVN::Fetcher->new($self, $gs->path);
1160                        $gs->ra->gs_do_switch($r0, $rev, $gs,
1161                                              $self->full_url, $ed)
1162                          or die "SVN connection failed somewhere...\n";
1163                } elsif ($self->ra->trees_match($new_url, $r0,
1164                                                $self->full_url, $rev)) {
1165                        print STDERR "Trees match:\n",
1166                                     "  $new_url\@$r0\n",
1167                                     "  ${\$self->full_url}\@$rev\n",
1168                                     "Following parent with no changes\n"
1169                                     unless $::_q > 1;
1170                        $self->tmp_index_do(sub {
1171                            command_noisy('read-tree', $parent);
1172                        });
1173                        $self->{last_commit} = $parent;
1174                } else {
1175                        print STDERR "Following parent with do_update\n"
1176                                     unless $::_q > 1;
1177                        $ed = Git::SVN::Fetcher->new($self);
1178                        $self->ra->gs_do_update($rev, $rev, $self, $ed)
1179                          or die "SVN connection failed somewhere...\n";
1180                }
1181                print STDERR "Successfully followed parent\n" unless $::_q > 1;
1182                return $self->make_log_entry($rev, [$parent], $ed, $r0, $branch_from);
1183        }
1184        return undef;
1185}
1186
1187sub do_fetch {
1188        my ($self, $paths, $rev) = @_;
1189        my $ed;
1190        my ($last_rev, @parents);
1191        if (my $lc = $self->last_commit) {
1192                # we can have a branch that was deleted, then re-added
1193                # under the same name but copied from another path, in
1194                # which case we'll have multiple parents (we don't
1195                # want to break the original ref or lose copypath info):
1196                if (my $log_entry = $self->find_parent_branch($paths, $rev)) {
1197                        push @{$log_entry->{parents}}, $lc;
1198                        return $log_entry;
1199                }
1200                $ed = Git::SVN::Fetcher->new($self);
1201                $last_rev = $self->{last_rev};
1202                $ed->{c} = $lc;
1203                @parents = ($lc);
1204        } else {
1205                $last_rev = $rev;
1206                if (my $log_entry = $self->find_parent_branch($paths, $rev)) {
1207                        return $log_entry;
1208                }
1209                $ed = Git::SVN::Fetcher->new($self);
1210        }
1211        unless ($self->ra->gs_do_update($last_rev, $rev, $self, $ed)) {
1212                die "SVN connection failed somewhere...\n";
1213        }
1214        $self->make_log_entry($rev, \@parents, $ed, $last_rev, $self->path);
1215}
1216
1217sub mkemptydirs {
1218        my ($self, $r) = @_;
1219
1220        sub scan {
1221                my ($r, $empty_dirs, $line) = @_;
1222                if (defined $r && $line =~ /^r(\d+)$/) {
1223                        return 0 if $1 > $r;
1224                } elsif ($line =~ /^  \+empty_dir: (.+)$/) {
1225                        $empty_dirs->{$1} = 1;
1226                } elsif ($line =~ /^  \-empty_dir: (.+)$/) {
1227                        my @d = grep {m[^\Q$1\E(/|$)]} (keys %$empty_dirs);
1228                        delete @$empty_dirs{@d};
1229                }
1230                1; # continue
1231        };
1232
1233        my %empty_dirs = ();
1234        my $gz_file = "$self->{dir}/unhandled.log.gz";
1235        if (-f $gz_file) {
1236                if (!can_compress()) {
1237                        warn "Compress::Zlib could not be found; ",
1238                             "empty directories in $gz_file will not be read\n";
1239                } else {
1240                        my $gz = Compress::Zlib::gzopen($gz_file, "rb") or
1241                                die "Unable to open $gz_file: $!\n";
1242                        my $line;
1243                        while ($gz->gzreadline($line) > 0) {
1244                                scan($r, \%empty_dirs, $line) or last;
1245                        }
1246                        $gz->gzclose;
1247                }
1248        }
1249
1250        if (open my $fh, '<', "$self->{dir}/unhandled.log") {
1251                binmode $fh or croak "binmode: $!";
1252                while (<$fh>) {
1253                        scan($r, \%empty_dirs, $_) or last;
1254                }
1255                close $fh;
1256        }
1257
1258        my $strip = qr/\A\Q@{[$self->path]}\E(?:\/|$)/;
1259        foreach my $d (sort keys %empty_dirs) {
1260                $d = uri_decode($d);
1261                $d =~ s/$strip//;
1262                next unless length($d);
1263                next if -d $d;
1264                if (-e $d) {
1265                        warn "$d exists but is not a directory\n";
1266                } else {
1267                        print "creating empty directory: $d\n";
1268                        mkpath([$d]);
1269                }
1270        }
1271}
1272
1273sub get_untracked {
1274        my ($self, $ed) = @_;
1275        my @out;
1276        my $h = $ed->{empty};
1277        foreach (sort keys %$h) {
1278                my $act = $h->{$_} ? '+empty_dir' : '-empty_dir';
1279                push @out, "  $act: " . uri_encode($_);
1280                warn "W: $act: $_\n";
1281        }
1282        foreach my $t (qw/dir_prop file_prop/) {
1283                $h = $ed->{$t} or next;
1284                foreach my $path (sort keys %$h) {
1285                        my $ppath = $path eq '' ? '.' : $path;
1286                        foreach my $prop (sort keys %{$h->{$path}}) {
1287                                next if $SKIP_PROP{$prop};
1288                                my $v = $h->{$path}->{$prop};
1289                                my $t_ppath_prop = "$t: " .
1290                                                    uri_encode($ppath) . ' ' .
1291                                                    uri_encode($prop);
1292                                if (defined $v) {
1293                                        push @out, "  +$t_ppath_prop " .
1294                                                   uri_encode($v);
1295                                } else {
1296                                        push @out, "  -$t_ppath_prop";
1297                                }
1298                        }
1299                }
1300        }
1301        foreach my $t (qw/absent_file absent_directory/) {
1302                $h = $ed->{$t} or next;
1303                foreach my $parent (sort keys %$h) {
1304                        foreach my $path (sort @{$h->{$parent}}) {
1305                                push @out, "  $t: " .
1306                                           uri_encode("$parent/$path");
1307                                warn "W: $t: $parent/$path ",
1308                                     "Insufficient permissions?\n";
1309                        }
1310                }
1311        }
1312        \@out;
1313}
1314
1315# parse_svn_date(DATE)
1316# --------------------
1317# Given a date (in UTC) from Subversion, return a string in the format
1318# "<TZ Offset> <local date/time>" that Git will use.
1319#
1320# By default the parsed date will be in UTC; if $Git::SVN::_localtime
1321# is true we'll convert it to the local timezone instead.
1322sub parse_svn_date {
1323        my $date = shift || return '+0000 1970-01-01 00:00:00';
1324        my ($Y,$m,$d,$H,$M,$S) = ($date =~ /^(\d{4})\-(\d\d)\-(\d\d)T
1325                                            (\d\d?)\:(\d\d)\:(\d\d)\.\d*Z$/x) or
1326                                         croak "Unable to parse date: $date\n";
1327        my $parsed_date;    # Set next.
1328
1329        if ($Git::SVN::_localtime) {
1330                # Translate the Subversion datetime to an epoch time.
1331                # Begin by switching ourselves to $date's timezone, UTC.
1332                my $old_env_TZ = $ENV{TZ};
1333                $ENV{TZ} = 'UTC';
1334
1335                my $epoch_in_UTC =
1336                    Time::Local::timelocal($S, $M, $H, $d, $m - 1, $Y - 1900);
1337
1338                # Determine our local timezone (including DST) at the
1339                # time of $epoch_in_UTC.  $Git::SVN::Log::TZ stored the
1340                # value of TZ, if any, at the time we were run.
1341                if (defined $Git::SVN::Log::TZ) {
1342                        $ENV{TZ} = $Git::SVN::Log::TZ;
1343                } else {
1344                        delete $ENV{TZ};
1345                }
1346
1347                my $our_TZ = get_tz_offset();
1348
1349                # This converts $epoch_in_UTC into our local timezone.
1350                my ($sec, $min, $hour, $mday, $mon, $year,
1351                    $wday, $yday, $isdst) = localtime($epoch_in_UTC);
1352
1353                $parsed_date = sprintf('%s %04d-%02d-%02d %02d:%02d:%02d',
1354                                       $our_TZ, $year + 1900, $mon + 1,
1355                                       $mday, $hour, $min, $sec);
1356
1357                # Reset us to the timezone in effect when we entered
1358                # this routine.
1359                if (defined $old_env_TZ) {
1360                        $ENV{TZ} = $old_env_TZ;
1361                } else {
1362                        delete $ENV{TZ};
1363                }
1364        } else {
1365                $parsed_date = "+0000 $Y-$m-$d $H:$M:$S";
1366        }
1367
1368        return $parsed_date;
1369}
1370
1371sub other_gs {
1372        my ($self, $new_url, $url,
1373            $branch_from, $r, $old_ref_id) = @_;
1374        my $gs = Git::SVN->find_by_url($new_url, $url, $branch_from);
1375        unless ($gs) {
1376                my $ref_id = $old_ref_id;
1377                $ref_id =~ s/\@\d+-*$//;
1378                $ref_id .= "\@$r";
1379                # just grow a tail if we're not unique enough :x
1380                $ref_id .= '-' while find_ref($ref_id);
1381                my ($u, $p, $repo_id) = ($new_url, '', $ref_id);
1382                if ($u =~ s#^\Q$url\E(/|$)##) {
1383                        $p = $u;
1384                        $u = $url;
1385                        $repo_id = $self->{repo_id};
1386                }
1387                while (1) {
1388                        # It is possible to tag two different subdirectories at
1389                        # the same revision.  If the url for an existing ref
1390                        # does not match, we must either find a ref with a
1391                        # matching url or create a new ref by growing a tail.
1392                        $gs = Git::SVN->init($u, $p, $repo_id, $ref_id, 1);
1393                        my (undef, $max_commit) = $gs->rev_map_max(1);
1394                        last if (!$max_commit);
1395                        my ($url) = ::cmt_metadata($max_commit);
1396                        last if ($url eq $gs->metadata_url);
1397                        $ref_id .= '-';
1398                }
1399                print STDERR "Initializing parent: $ref_id\n" unless $::_q > 1;
1400        }
1401        $gs
1402}
1403
1404sub call_authors_prog {
1405        my ($orig_author) = @_;
1406        $orig_author = command_oneline('rev-parse', '--sq-quote', $orig_author);
1407        my $author = `$::_authors_prog $orig_author`;
1408        if ($? != 0) {
1409                die "$::_authors_prog failed with exit code $?\n"
1410        }
1411        if ($author =~ /^\s*(.+?)\s*<(.*)>\s*$/) {
1412                my ($name, $email) = ($1, $2);
1413                $email = undef if length $2 == 0;
1414                return [$name, $email];
1415        } else {
1416                die "Author: $orig_author: $::_authors_prog returned "
1417                        . "invalid author format: $author\n";
1418        }
1419}
1420
1421sub check_author {
1422        my ($author) = @_;
1423        if (!defined $author || length $author == 0) {
1424                $author = '(no author)';
1425        }
1426        if (!defined $::users{$author}) {
1427                if (defined $::_authors_prog) {
1428                        $::users{$author} = call_authors_prog($author);
1429                } elsif (defined $::_authors) {
1430                        die "Author: $author not defined in $::_authors file\n";
1431                }
1432        }
1433        $author;
1434}
1435
1436sub find_extra_svk_parents {
1437        my ($self, $tickets, $parents) = @_;
1438        # aha!  svk:merge property changed...
1439        my @tickets = split "\n", $tickets;
1440        my @known_parents;
1441        for my $ticket ( @tickets ) {
1442                my ($uuid, $path, $rev) = split /:/, $ticket;
1443                if ( $uuid eq $self->ra_uuid ) {
1444                        my $repos_root = $self->url;
1445                        my $branch_from = $path;
1446                        $branch_from =~ s{^/}{};
1447                        my $gs = $self->other_gs(add_path_to_url( $repos_root, $branch_from ),
1448                                                 $repos_root,
1449                                                 $branch_from,
1450                                                 $rev,
1451                                                 $self->{ref_id});
1452                        if ( my $commit = $gs->rev_map_get($rev, $uuid) ) {
1453                                # wahey!  we found it, but it might be
1454                                # an old one (!)
1455                                push @known_parents, [ $rev, $commit ];
1456                        }
1457                }
1458        }
1459        # Ordering matters; highest-numbered commit merge tickets
1460        # first, as they may account for later merge ticket additions
1461        # or changes.
1462        @known_parents = map {$_->[1]} sort {$b->[0] <=> $a->[0]} @known_parents;
1463        for my $parent ( @known_parents ) {
1464                my @cmd = ('rev-list', $parent, map { "^$_" } @$parents );
1465                my ($msg_fh, $ctx) = command_output_pipe(@cmd);
1466                my $new;
1467                while ( <$msg_fh> ) {
1468                        $new=1;last;
1469                }
1470                command_close_pipe($msg_fh, $ctx);
1471                if ( $new ) {
1472                        print STDERR
1473                            "Found merge parent (svk:merge ticket): $parent\n";
1474                        push @$parents, $parent;
1475                }
1476        }
1477}
1478
1479sub lookup_svn_merge {
1480        my $uuid = shift;
1481        my $url = shift;
1482        my $source = shift;
1483        my $revs = shift;
1484
1485        my $path = $source;
1486        $path =~ s{^/}{};
1487        my $gs = Git::SVN->find_by_url($url.$source, $url, $path);
1488        if ( !$gs ) {
1489                warn "Couldn't find revmap for $url$source\n";
1490                return;
1491        }
1492        my @ranges = split ",", $revs;
1493        my ($tip, $tip_commit);
1494        my @merged_commit_ranges;
1495        # find the tip
1496        for my $range ( @ranges ) {
1497                if ($range =~ /[*]$/) {
1498                        warn "W: Ignoring partial merge in svn:mergeinfo "
1499                                ."dirprop: $source:$range\n";
1500                        next;
1501                }
1502                my ($bottom, $top) = split "-", $range;
1503                $top ||= $bottom;
1504                my $bottom_commit = $gs->find_rev_after( $bottom, 1, $top );
1505                my $top_commit = $gs->find_rev_before( $top, 1, $bottom );
1506
1507                unless ($top_commit and $bottom_commit) {
1508                        warn "W: unknown path/rev in svn:mergeinfo "
1509                                ."dirprop: $source:$range\n";
1510                        next;
1511                }
1512
1513                if (scalar(command('rev-parse', "$bottom_commit^@"))) {
1514                        push @merged_commit_ranges,
1515                             "$bottom_commit^..$top_commit";
1516                } else {
1517                        push @merged_commit_ranges, "$top_commit";
1518                }
1519
1520                if ( !defined $tip or $top > $tip ) {
1521                        $tip = $top;
1522                        $tip_commit = $top_commit;
1523                }
1524        }
1525        return ($tip_commit, @merged_commit_ranges);
1526}
1527
1528sub _rev_list {
1529        my ($msg_fh, $ctx) = command_output_pipe(
1530                "rev-list", @_,
1531               );
1532        my @rv;
1533        while ( <$msg_fh> ) {
1534                chomp;
1535                push @rv, $_;
1536        }
1537        command_close_pipe($msg_fh, $ctx);
1538        @rv;
1539}
1540
1541sub check_cherry_pick2 {
1542        my $base = shift;
1543        my $tip = shift;
1544        my $parents = shift;
1545        my @ranges = @_;
1546        my %commits = map { $_ => 1 }
1547                _rev_list("--no-merges", $tip, "--not", $base, @$parents, "--");
1548        for my $range ( @ranges ) {
1549                delete @commits{_rev_list($range, "--")};
1550        }
1551        for my $commit (keys %commits) {
1552                if (has_no_changes($commit)) {
1553                        delete $commits{$commit};
1554                }
1555        }
1556        my @k = (keys %commits);
1557        return (scalar @k, $k[0]);
1558}
1559
1560sub has_no_changes {
1561        my $commit = shift;
1562
1563        my @revs = split / /, command_oneline(
1564                qw(rev-list --parents -1 -m), $commit);
1565
1566        # Commits with no parents, e.g. the start of a partial branch,
1567        # have changes by definition.
1568        return 1 if (@revs < 2);
1569
1570        # Commits with multiple parents, e.g a merge, have no changes
1571        # by definition.
1572        return 0 if (@revs > 2);
1573
1574        return (command_oneline("rev-parse", "$commit^{tree}") eq
1575                command_oneline("rev-parse", "$commit~1^{tree}"));
1576}
1577
1578sub tie_for_persistent_memoization {
1579        my $hash = shift;
1580        my $path = shift;
1581
1582        if ($can_use_yaml) {
1583                tie %$hash => 'Git::SVN::Memoize::YAML', "$path.yaml";
1584        } else {
1585                tie %$hash => 'Memoize::Storable', "$path.db", 'nstore';
1586        }
1587}
1588
1589# The GIT_DIR environment variable is not always set until after the command
1590# line arguments are processed, so we can't memoize in a BEGIN block.
1591{
1592        my $memoized = 0;
1593
1594        sub memoize_svn_mergeinfo_functions {
1595                return if $memoized;
1596                $memoized = 1;
1597
1598                my $cache_path = "$ENV{GIT_DIR}/svn/.caches/";
1599                mkpath([$cache_path]) unless -d $cache_path;
1600
1601                my %lookup_svn_merge_cache;
1602                my %check_cherry_pick2_cache;
1603                my %has_no_changes_cache;
1604
1605                tie_for_persistent_memoization(\%lookup_svn_merge_cache,
1606                    "$cache_path/lookup_svn_merge");
1607                memoize 'lookup_svn_merge',
1608                        SCALAR_CACHE => 'FAULT',
1609                        LIST_CACHE => ['HASH' => \%lookup_svn_merge_cache],
1610                ;
1611
1612                tie_for_persistent_memoization(\%check_cherry_pick2_cache,
1613                    "$cache_path/check_cherry_pick2");
1614                memoize 'check_cherry_pick2',
1615                        SCALAR_CACHE => 'FAULT',
1616                        LIST_CACHE => ['HASH' => \%check_cherry_pick2_cache],
1617                ;
1618
1619                tie_for_persistent_memoization(\%has_no_changes_cache,
1620                    "$cache_path/has_no_changes");
1621                memoize 'has_no_changes',
1622                        SCALAR_CACHE => ['HASH' => \%has_no_changes_cache],
1623                        LIST_CACHE => 'FAULT',
1624                ;
1625        }
1626
1627        sub unmemoize_svn_mergeinfo_functions {
1628                return if not $memoized;
1629                $memoized = 0;
1630
1631                Memoize::unmemoize 'lookup_svn_merge';
1632                Memoize::unmemoize 'check_cherry_pick2';
1633                Memoize::unmemoize 'has_no_changes';
1634        }
1635
1636        sub clear_memoized_mergeinfo_caches {
1637                die "Only call this method in non-memoized context" if ($memoized);
1638
1639                my $cache_path = "$ENV{GIT_DIR}/svn/.caches/";
1640                return unless -d $cache_path;
1641
1642                for my $cache_file (("$cache_path/lookup_svn_merge",
1643                                     "$cache_path/check_cherry_pick", # old
1644                                     "$cache_path/check_cherry_pick2",
1645                                     "$cache_path/has_no_changes")) {
1646                        for my $suffix (qw(yaml db)) {
1647                                my $file = "$cache_file.$suffix";
1648                                next unless -e $file;
1649                                unlink($file) or die "unlink($file) failed: $!\n";
1650                        }
1651                }
1652        }
1653
1654
1655        Memoize::memoize 'Git::SVN::repos_root';
1656}
1657
1658END {
1659        # Force cache writeout explicitly instead of waiting for
1660        # global destruction to avoid segfault in Storable:
1661        # http://rt.cpan.org/Public/Bug/Display.html?id=36087
1662        unmemoize_svn_mergeinfo_functions();
1663}
1664
1665sub parents_exclude {
1666        my $parents = shift;
1667        my @commits = @_;
1668        return unless @commits;
1669
1670        my @excluded;
1671        my $excluded;
1672        do {
1673                my @cmd = ('rev-list', "-1", @commits, "--not", @$parents );
1674                $excluded = command_oneline(@cmd);
1675                if ( $excluded ) {
1676                        my @new;
1677                        my $found;
1678                        for my $commit ( @commits ) {
1679                                if ( $commit eq $excluded ) {
1680                                        push @excluded, $commit;
1681                                        $found++;
1682                                }
1683                                else {
1684                                        push @new, $commit;
1685                                }
1686                        }
1687                        die "saw commit '$excluded' in rev-list output, "
1688                                ."but we didn't ask for that commit (wanted: @commits --not @$parents)"
1689                                        unless $found;
1690                        @commits = @new;
1691                }
1692        }
1693                while ($excluded and @commits);
1694
1695        return @excluded;
1696}
1697
1698# Compute what's new in svn:mergeinfo.
1699sub mergeinfo_changes {
1700        my ($self, $old_path, $old_rev, $path, $rev, $mergeinfo_prop) = @_;
1701        my %minfo = map {split ":", $_ } split "\n", $mergeinfo_prop;
1702        my $old_minfo = {};
1703
1704        my $ra = $self->ra;
1705        # Give up if $old_path isn't in the repo.
1706        # This is probably a merge on a subtree.
1707        if ($ra->check_path($old_path, $old_rev) != $SVN::Node::dir) {
1708                warn "W: ignoring svn:mergeinfo on $old_path, ",
1709                        "directory didn't exist in r$old_rev\n";
1710                return {};
1711        }
1712        my (undef, undef, $props) = $ra->get_dir($old_path, $old_rev);
1713        if (defined $props->{"svn:mergeinfo"}) {
1714                my %omi = map {split ":", $_ } split "\n",
1715                        $props->{"svn:mergeinfo"};
1716                $old_minfo = \%omi;
1717        }
1718
1719        my %changes = ();
1720        foreach my $p (keys %minfo) {
1721                my $a = $old_minfo->{$p} || "";
1722                my $b = $minfo{$p};
1723                # Omit merged branches whose ranges lists are unchanged.
1724                next if $a eq $b;
1725                # Remove any common range list prefix.
1726                ($a ^ $b) =~ /^[\0]*/;
1727                my $common_prefix = rindex $b, ",", $+[0] - 1;
1728                $changes{$p} = substr $b, $common_prefix + 1;
1729        }
1730        print STDERR "Checking svn:mergeinfo changes since r$old_rev: ",
1731                scalar(keys %minfo), " sources, ",
1732                scalar(keys %changes), " changed\n";
1733
1734        return \%changes;
1735}
1736
1737# note: this function should only be called if the various dirprops
1738# have actually changed
1739sub find_extra_svn_parents {
1740        my ($self, $mergeinfo, $parents) = @_;
1741        # aha!  svk:merge property changed...
1742
1743        memoize_svn_mergeinfo_functions();
1744
1745        # We first search for merged tips which are not in our
1746        # history.  Then, we figure out which git revisions are in
1747        # that tip, but not this revision.  If all of those revisions
1748        # are now marked as merge, we can add the tip as a parent.
1749        my @merges = sort keys %$mergeinfo;
1750        my @merge_tips;
1751        my $url = $self->url;
1752        my $uuid = $self->ra_uuid;
1753        my @all_ranges;
1754        for my $merge ( @merges ) {
1755                my ($tip_commit, @ranges) =
1756                        lookup_svn_merge( $uuid, $url,
1757                                          $merge, $mergeinfo->{$merge} );
1758                unless (!$tip_commit or
1759                                grep { $_ eq $tip_commit } @$parents ) {
1760                        push @merge_tips, $tip_commit;
1761                        push @all_ranges, @ranges;
1762                } else {
1763                        push @merge_tips, undef;
1764                }
1765        }
1766
1767        my %excluded = map { $_ => 1 }
1768                parents_exclude($parents, grep { defined } @merge_tips);
1769
1770        # check merge tips for new parents
1771        my @new_parents;
1772        for my $merge_tip ( @merge_tips ) {
1773                my $merge = shift @merges;
1774                next unless $merge_tip and $excluded{$merge_tip};
1775                my $spec = "$merge:$mergeinfo->{$merge}";
1776
1777                # check out 'new' tips
1778                my $merge_base;
1779                eval {
1780                        $merge_base = command_oneline(
1781                                "merge-base",
1782                                @$parents, $merge_tip,
1783                        );
1784                };
1785                if ($@) {
1786                        die "An error occurred during merge-base"
1787                                unless $@->isa("Git::Error::Command");
1788
1789                        warn "W: Cannot find common ancestor between ".
1790                             "@$parents and $merge_tip. Ignoring merge info.\n";
1791                        next;
1792                }
1793
1794                # double check that there are no missing non-merge commits
1795                my ($ninc, $ifirst) = check_cherry_pick2(
1796                        $merge_base, $merge_tip,
1797                        $parents,
1798                        @all_ranges,
1799                       );
1800
1801                if ($ninc) {
1802                        warn "W: svn cherry-pick ignored ($spec) - missing " .
1803                                "$ninc commit(s) (eg $ifirst)\n";
1804                } else {
1805                        warn "Found merge parent ($spec): ", $merge_tip, "\n";
1806                        push @new_parents, $merge_tip;
1807                }
1808        }
1809
1810        # cater for merges which merge commits from multiple branches
1811        if ( @new_parents > 1 ) {
1812                for ( my $i = 0; $i <= $#new_parents; $i++ ) {
1813                        for ( my $j = 0; $j <= $#new_parents; $j++ ) {
1814                                next if $i == $j;
1815                                next unless $new_parents[$i];
1816                                next unless $new_parents[$j];
1817                                my $revs = command_oneline(
1818                                        "rev-list", "-1",
1819                                        "$new_parents[$i]..$new_parents[$j]",
1820                                       );
1821                                if ( !$revs ) {
1822                                        undef($new_parents[$j]);
1823                                }
1824                        }
1825                }
1826        }
1827        push @$parents, grep { defined } @new_parents;
1828}
1829
1830sub make_log_entry {
1831        my ($self, $rev, $parents, $ed, $parent_rev, $parent_path) = @_;
1832        my $untracked = $self->get_untracked($ed);
1833
1834        my @parents = @$parents;
1835        my $props = $ed->{dir_prop}{$self->path};
1836        if ( $props->{"svk:merge"} ) {
1837                $self->find_extra_svk_parents($props->{"svk:merge"}, \@parents);
1838        }
1839        if ( $props->{"svn:mergeinfo"} ) {
1840                my $mi_changes = $self->mergeinfo_changes
1841                        ($parent_path, $parent_rev,
1842                         $self->path, $rev,
1843                         $props->{"svn:mergeinfo"});
1844                $self->find_extra_svn_parents($mi_changes, \@parents);
1845        }
1846
1847        open my $un, '>>', "$self->{dir}/unhandled.log" or croak $!;
1848        print $un "r$rev\n" or croak $!;
1849        print $un $_, "\n" foreach @$untracked;
1850        my %log_entry = ( parents => \@parents, revision => $rev,
1851                          log => '');
1852
1853        my $headrev;
1854        my $logged = delete $self->{logged_rev_props};
1855        if (!$logged || $self->{-want_revprops}) {
1856                my $rp = $self->ra->rev_proplist($rev);
1857                foreach (sort keys %$rp) {
1858                        my $v = $rp->{$_};
1859                        if (/^svn:(author|date|log)$/) {
1860                                $log_entry{$1} = $v;
1861                        } elsif ($_ eq 'svm:headrev') {
1862                                $headrev = $v;
1863                        } else {
1864                                print $un "  rev_prop: ", uri_encode($_), ' ',
1865                                          uri_encode($v), "\n";
1866                        }
1867                }
1868        } else {
1869                map { $log_entry{$_} = $logged->{$_} } keys %$logged;
1870        }
1871        close $un or croak $!;
1872
1873        $log_entry{date} = parse_svn_date($log_entry{date});
1874        $log_entry{log} .= "\n";
1875        my $author = $log_entry{author} = check_author($log_entry{author});
1876        my ($name, $email) = defined $::users{$author} ? @{$::users{$author}}
1877                                                       : ($author, undef);
1878
1879        my ($commit_name, $commit_email) = ($name, $email);
1880        if ($_use_log_author) {
1881                my $name_field;
1882                if ($log_entry{log} =~ /From:\s+(.*\S)\s*\n/i) {
1883                        $name_field = $1;
1884                } elsif ($log_entry{log} =~ /Signed-off-by:\s+(.*\S)\s*\n/i) {
1885                        $name_field = $1;
1886                }
1887                if (!defined $name_field) {
1888                        if (!defined $email) {
1889                                $email = $name;
1890                        }
1891                } elsif ($name_field =~ /(.*?)\s+<(.*)>/) {
1892                        ($name, $email) = ($1, $2);
1893                } elsif ($name_field =~ /(.*)@/) {
1894                        ($name, $email) = ($1, $name_field);
1895                } else {
1896                        ($name, $email) = ($name_field, $name_field);
1897                }
1898        }
1899        if (defined $headrev && $self->use_svm_props) {
1900                if ($self->rewrite_root) {
1901                        die "Can't have both 'useSvmProps' and 'rewriteRoot' ",
1902                            "options set!\n";
1903                }
1904                if ($self->rewrite_uuid) {
1905                        die "Can't have both 'useSvmProps' and 'rewriteUUID' ",
1906                            "options set!\n";
1907                }
1908                my ($uuid, $r) = $headrev =~ m{^([a-f\d\-]{30,}):(\d+)$}i;
1909                # we don't want "SVM: initializing mirror for junk" ...
1910                return undef if $r == 0;
1911                my $svm = $self->svm;
1912                if ($uuid ne $svm->{uuid}) {
1913                        die "UUID mismatch on SVM path:\n",
1914                            "expected: $svm->{uuid}\n",
1915                            "     got: $uuid\n";
1916                }
1917                my $full_url = $self->full_url;
1918                $full_url =~ s#^\Q$svm->{replace}\E(/|$)#$svm->{source}$1# or
1919                             die "Failed to replace '$svm->{replace}' with ",
1920                                 "'$svm->{source}' in $full_url\n";
1921                # throw away username for storing in records
1922                remove_username($full_url);
1923                $log_entry{metadata} = "$full_url\@$r $uuid";
1924                $log_entry{svm_revision} = $r;
1925                $email ||= "$author\@$uuid";
1926                $commit_email ||= "$author\@$uuid";
1927        } elsif ($self->use_svnsync_props) {
1928                my $full_url = canonicalize_url(
1929                        add_path_to_url( $self->svnsync->{url}, $self->path )
1930                );
1931                remove_username($full_url);
1932                my $uuid = $self->svnsync->{uuid};
1933                $log_entry{metadata} = "$full_url\@$rev $uuid";
1934                $email ||= "$author\@$uuid";
1935                $commit_email ||= "$author\@$uuid";
1936        } else {
1937                my $url = $self->metadata_url;
1938                remove_username($url);
1939                my $uuid = $self->rewrite_uuid || $self->ra->get_uuid;
1940                $log_entry{metadata} = "$url\@$rev " . $uuid;
1941                $email ||= "$author\@" . $uuid;
1942                $commit_email ||= "$author\@" . $uuid;
1943        }
1944        $log_entry{name} = $name;
1945        $log_entry{email} = $email;
1946        $log_entry{commit_name} = $commit_name;
1947        $log_entry{commit_email} = $commit_email;
1948        \%log_entry;
1949}
1950
1951sub fetch {
1952        my ($self, $min_rev, $max_rev, @parents) = @_;
1953        my ($last_rev, $last_commit) = $self->last_rev_commit;
1954        my ($base, $head) = $self->get_fetch_range($min_rev, $max_rev);
1955        $self->ra->gs_fetch_loop_common($base, $head, [$self]);
1956}
1957
1958sub set_tree_cb {
1959        my ($self, $log_entry, $tree, $rev, $date, $author) = @_;
1960        $self->{inject_parents} = { $rev => $tree };
1961        $self->fetch(undef, undef);
1962}
1963
1964sub set_tree {
1965        my ($self, $tree) = (shift, shift);
1966        my $log_entry = ::get_commit_entry($tree);
1967        unless ($self->{last_rev}) {
1968                fatal("Must have an existing revision to commit");
1969        }
1970        my %ed_opts = ( r => $self->{last_rev},
1971                        log => $log_entry->{log},
1972                        ra => $self->ra,
1973                        tree_a => $self->{last_commit},
1974                        tree_b => $tree,
1975                        editor_cb => sub {
1976                               $self->set_tree_cb($log_entry, $tree, @_) },
1977                        svn_path => $self->path );
1978        if (!Git::SVN::Editor->new(\%ed_opts)->apply_diff) {
1979                print "No changes\nr$self->{last_rev} = $tree\n";
1980        }
1981}
1982
1983sub rebuild_from_rev_db {
1984        my ($self, $path) = @_;
1985        my $r = -1;
1986        open my $fh, '<', $path or croak "open: $!";
1987        binmode $fh or croak "binmode: $!";
1988        while (<$fh>) {
1989                length($_) == 41 or croak "inconsistent size in ($_) != 41";
1990                chomp($_);
1991                ++$r;
1992                next if $_ eq ('0' x 40);
1993                $self->rev_map_set($r, $_);
1994                print "r$r = $_\n";
1995        }
1996        close $fh or croak "close: $!";
1997        unlink $path or croak "unlink: $!";
1998}
1999
2000#define a global associate map to record rebuild status
2001my %rebuild_status;
2002#define a global associate map to record rebuild verify status
2003my %rebuild_verify_status;
2004
2005sub rebuild {
2006        my ($self) = @_;
2007        my $map_path = $self->map_path;
2008        my $partial = (-e $map_path && ! -z $map_path);
2009        my $verify_key = $self->refname.'^0';
2010        if (!$rebuild_verify_status{$verify_key}) {
2011                my $verify_result = ::verify_ref($verify_key);
2012                if ($verify_result) {
2013                        $rebuild_verify_status{$verify_key} = 1;
2014                }
2015        }
2016        if (!$rebuild_verify_status{$verify_key}) {
2017                return;
2018        }
2019        if (!$partial && ($self->use_svm_props || $self->no_metadata)) {
2020                my $rev_db = $self->rev_db_path;
2021                $self->rebuild_from_rev_db($rev_db);
2022                if ($self->use_svm_props) {
2023                        my $svm_rev_db = $self->rev_db_path($self->svm_uuid);
2024                        $self->rebuild_from_rev_db($svm_rev_db);
2025                }
2026                $self->unlink_rev_db_symlink;
2027                return;
2028        }
2029        print "Rebuilding $map_path ...\n" if (!$partial);
2030        my ($base_rev, $head) = ($partial ? $self->rev_map_max_norebuild(1) :
2031                (undef, undef));
2032        my $key_value = ($head ? "$head.." : "") . $self->refname;
2033        if (exists $rebuild_status{$key_value}) {
2034                print "Done rebuilding $map_path\n" if (!$partial || !$head);
2035                my $rev_db_path = $self->rev_db_path;
2036                if (-f $self->rev_db_path) {
2037                        unlink $self->rev_db_path or croak "unlink: $!";
2038                }
2039                $self->unlink_rev_db_symlink;
2040                return;
2041        }
2042        my ($log, $ctx) =
2043                command_output_pipe(qw/rev-list --pretty=raw --reverse/,
2044                                $key_value,
2045                                '--');
2046        $rebuild_status{$key_value} = 1;
2047        my $metadata_url = $self->metadata_url;
2048        remove_username($metadata_url);
2049        my $svn_uuid = $self->rewrite_uuid || $self->ra_uuid;
2050        my $c;
2051        while (<$log>) {
2052                if ( m{^commit ($::sha1)$} ) {
2053                        $c = $1;
2054                        next;
2055                }
2056                next unless s{^\s*(git-svn-id:)}{$1};
2057                my ($url, $rev, $uuid) = ::extract_metadata($_);
2058                remove_username($url);
2059
2060                # ignore merges (from set-tree)
2061                next if (!defined $rev || !$uuid);
2062
2063                # if we merged or otherwise started elsewhere, this is
2064                # how we break out of it
2065                if (($uuid ne $svn_uuid) ||
2066                    ($metadata_url && $url && ($url ne $metadata_url))) {
2067                        next;
2068                }
2069                if ($partial && $head) {
2070                        print "Partial-rebuilding $map_path ...\n";
2071                        print "Currently at $base_rev = $head\n";
2072                        $head = undef;
2073                }
2074
2075                $self->rev_map_set($rev, $c);
2076                print "r$rev = $c\n";
2077        }
2078        command_close_pipe($log, $ctx);
2079        print "Done rebuilding $map_path\n" if (!$partial || !$head);
2080        my $rev_db_path = $self->rev_db_path;
2081        if (-f $self->rev_db_path) {
2082                unlink $self->rev_db_path or croak "unlink: $!";
2083        }
2084        $self->unlink_rev_db_symlink;
2085}
2086
2087# rev_map:
2088# Tie::File seems to be prone to offset errors if revisions get sparse,
2089# it's not that fast, either.  Tie::File is also not in Perl 5.6.  So
2090# one of my favorite modules is out :<  Next up would be one of the DBM
2091# modules, but I'm not sure which is most portable...
2092#
2093# This is the replacement for the rev_db format, which was too big
2094# and inefficient for large repositories with a lot of sparse history
2095# (mainly tags)
2096#
2097# The format is this:
2098#   - 24 bytes for every record,
2099#     * 4 bytes for the integer representing an SVN revision number
2100#     * 20 bytes representing the sha1 of a git commit
2101#   - No empty padding records like the old format
2102#     (except the last record, which can be overwritten)
2103#   - new records are written append-only since SVN revision numbers
2104#     increase monotonically
2105#   - lookups on SVN revision number are done via a binary search
2106#   - Piping the file to xxd -c24 is a good way of dumping it for
2107#     viewing or editing (piped back through xxd -r), should the need
2108#     ever arise.
2109#   - The last record can be padding revision with an all-zero sha1
2110#     This is used to optimize fetch performance when using multiple
2111#     "fetch" directives in .git/config
2112#
2113# These files are disposable unless noMetadata or useSvmProps is set
2114
2115sub _rev_map_set {
2116        my ($fh, $rev, $commit) = @_;
2117
2118        binmode $fh or croak "binmode: $!";
2119        my $size = (stat($fh))[7];
2120        ($size % 24) == 0 or croak "inconsistent size: $size";
2121
2122        my $wr_offset = 0;
2123        if ($size > 0) {
2124                sysseek($fh, -24, SEEK_END) or croak "seek: $!";
2125                my $read = sysread($fh, my $buf, 24) or croak "read: $!";
2126                $read == 24 or croak "read only $read bytes (!= 24)";
2127                my ($last_rev, $last_commit) = unpack(rev_map_fmt, $buf);
2128                if ($last_commit eq ('0' x40)) {
2129                        if ($size >= 48) {
2130                                sysseek($fh, -48, SEEK_END) or croak "seek: $!";
2131                                $read = sysread($fh, $buf, 24) or
2132                                    croak "read: $!";
2133                                $read == 24 or
2134                                    croak "read only $read bytes (!= 24)";
2135                                ($last_rev, $last_commit) =
2136                                    unpack(rev_map_fmt, $buf);
2137                                if ($last_commit eq ('0' x40)) {
2138                                        croak "inconsistent .rev_map\n";
2139                                }
2140                        }
2141                        if ($last_rev >= $rev) {
2142                                croak "last_rev is higher!: $last_rev >= $rev";
2143                        }
2144                        $wr_offset = -24;
2145                }
2146        }
2147        sysseek($fh, $wr_offset, SEEK_END) or croak "seek: $!";
2148        syswrite($fh, pack(rev_map_fmt, $rev, $commit), 24) == 24 or
2149          croak "write: $!";
2150}
2151
2152sub _rev_map_reset {
2153        my ($fh, $rev, $commit) = @_;
2154        my $c = _rev_map_get($fh, $rev);
2155        $c eq $commit or die "_rev_map_reset(@_) commit $c does not match!\n";
2156        my $offset = sysseek($fh, 0, SEEK_CUR) or croak "seek: $!";
2157        truncate $fh, $offset or croak "truncate: $!";
2158}
2159
2160sub mkfile {
2161        my ($path) = @_;
2162        unless (-e $path) {
2163                my ($dir, $base) = ($path =~ m#^(.*?)/?([^/]+)$#);
2164                mkpath([$dir]) unless -d $dir;
2165                open my $fh, '>>', $path or die "Couldn't create $path: $!\n";
2166                close $fh or die "Couldn't close (create) $path: $!\n";
2167        }
2168}
2169
2170sub rev_map_set {
2171        my ($self, $rev, $commit, $update_ref, $uuid) = @_;
2172        defined $commit or die "missing arg3\n";
2173        length $commit == 40 or die "arg3 must be a full SHA1 hexsum\n";
2174        my $db = $self->map_path($uuid);
2175        my $db_lock = "$db.lock";
2176        my $sigmask;
2177        $update_ref ||= 0;
2178        if ($update_ref) {
2179                $sigmask = POSIX::SigSet->new();
2180                my $signew = POSIX::SigSet->new(SIGINT, SIGHUP, SIGTERM,
2181                        SIGALRM, SIGUSR1, SIGUSR2);
2182                sigprocmask(SIG_BLOCK, $signew, $sigmask) or
2183                        croak "Can't block signals: $!";
2184        }
2185        mkfile($db);
2186
2187        $LOCKFILES{$db_lock} = 1;
2188        my $sync;
2189        # both of these options make our .rev_db file very, very important
2190        # and we can't afford to lose it because rebuild() won't work
2191        if ($self->use_svm_props || $self->no_metadata) {
2192                $sync = 1;
2193                copy($db, $db_lock) or die "rev_map_set(@_): ",
2194                                           "Failed to copy: ",
2195                                           "$db => $db_lock ($!)\n";
2196        } else {
2197                rename $db, $db_lock or die "rev_map_set(@_): ",
2198                                            "Failed to rename: ",
2199                                            "$db => $db_lock ($!)\n";
2200        }
2201
2202        sysopen(my $fh, $db_lock, O_RDWR | O_CREAT)
2203             or croak "Couldn't open $db_lock: $!\n";
2204        if ($update_ref eq 'reset') {
2205                clear_memoized_mergeinfo_caches();
2206                _rev_map_reset($fh, $rev, $commit);
2207        } else {
2208                _rev_map_set($fh, $rev, $commit);
2209        }
2210
2211        if ($sync) {
2212                $fh->flush or die "Couldn't flush $db_lock: $!\n";
2213                $fh->sync or die "Couldn't sync $db_lock: $!\n";
2214        }
2215        close $fh or croak $!;
2216        if ($update_ref) {
2217                $_head = $self;
2218                my $note = "";
2219                $note = " ($update_ref)" if ($update_ref !~ /^\d*$/);
2220                command_noisy('update-ref', '-m', "r$rev$note",
2221                              $self->refname, $commit);
2222        }
2223        rename $db_lock, $db or die "rev_map_set(@_): ", "Failed to rename: ",
2224                                    "$db_lock => $db ($!)\n";
2225        delete $LOCKFILES{$db_lock};
2226        if ($update_ref) {
2227                sigprocmask(SIG_SETMASK, $sigmask) or
2228                        croak "Can't restore signal mask: $!";
2229        }
2230}
2231
2232# If want_commit, this will return an array of (rev, commit) where
2233# commit _must_ be a valid commit in the archive.
2234# Otherwise, it'll return the max revision (whether or not the
2235# commit is valid or just a 0x40 placeholder).
2236sub rev_map_max {
2237        my ($self, $want_commit) = @_;
2238        $self->rebuild;
2239        my ($r, $c) = $self->rev_map_max_norebuild($want_commit);
2240        $want_commit ? ($r, $c) : $r;
2241}
2242
2243sub rev_map_max_norebuild {
2244        my ($self, $want_commit) = @_;
2245        my $map_path = $self->map_path;
2246        stat $map_path or return $want_commit ? (0, undef) : 0;
2247        sysopen(my $fh, $map_path, O_RDONLY) or croak "open: $!";
2248        binmode $fh or croak "binmode: $!";
2249        my $size = (stat($fh))[7];
2250        ($size % 24) == 0 or croak "inconsistent size: $size";
2251
2252        if ($size == 0) {
2253                close $fh or croak "close: $!";
2254                return $want_commit ? (0, undef) : 0;
2255        }
2256
2257        sysseek($fh, -24, SEEK_END) or croak "seek: $!";
2258        sysread($fh, my $buf, 24) == 24 or croak "read: $!";
2259        my ($r, $c) = unpack(rev_map_fmt, $buf);
2260        if ($want_commit && $c eq ('0' x40)) {
2261                if ($size < 48) {
2262                        return $want_commit ? (0, undef) : 0;
2263                }
2264                sysseek($fh, -48, SEEK_END) or croak "seek: $!";
2265                sysread($fh, $buf, 24) == 24 or croak "read: $!";
2266                ($r, $c) = unpack(rev_map_fmt, $buf);
2267                if ($c eq ('0'x40)) {
2268                        croak "Penultimate record is all-zeroes in $map_path";
2269                }
2270        }
2271        close $fh or croak "close: $!";
2272        $want_commit ? ($r, $c) : $r;
2273}
2274
2275sub rev_map_get {
2276        my ($self, $rev, $uuid) = @_;
2277        my $map_path = $self->map_path($uuid);
2278        return undef unless -e $map_path;
2279
2280        sysopen(my $fh, $map_path, O_RDONLY) or croak "open: $!";
2281        my $c = _rev_map_get($fh, $rev);
2282        close($fh) or croak "close: $!";
2283        $c
2284}
2285
2286sub _rev_map_get {
2287        my ($fh, $rev) = @_;
2288
2289        binmode $fh or croak "binmode: $!";
2290        my $size = (stat($fh))[7];
2291        ($size % 24) == 0 or croak "inconsistent size: $size";
2292
2293        if ($size == 0) {
2294                return undef;
2295        }
2296
2297        my ($l, $u) = (0, $size - 24);
2298        my ($r, $c, $buf);
2299
2300        while ($l <= $u) {
2301                my $i = int(($l/24 + $u/24) / 2) * 24;
2302                sysseek($fh, $i, SEEK_SET) or croak "seek: $!";
2303                sysread($fh, my $buf, 24) == 24 or croak "read: $!";
2304                my ($r, $c) = unpack(rev_map_fmt, $buf);
2305
2306                if ($r < $rev) {
2307                        $l = $i + 24;
2308                } elsif ($r > $rev) {
2309                        $u = $i - 24;
2310                } else { # $r == $rev
2311                        return $c eq ('0' x 40) ? undef : $c;
2312                }
2313        }
2314        undef;
2315}
2316
2317# Finds the first svn revision that exists on (if $eq_ok is true) or
2318# before $rev for the current branch.  It will not search any lower
2319# than $min_rev.  Returns the git commit hash and svn revision number
2320# if found, else (undef, undef).
2321sub find_rev_before {
2322        my ($self, $rev, $eq_ok, $min_rev) = @_;
2323        --$rev unless $eq_ok;
2324        $min_rev ||= 1;
2325        my $max_rev = $self->rev_map_max;
2326        $rev = $max_rev if ($rev > $max_rev);
2327        while ($rev >= $min_rev) {
2328                if (my $c = $self->rev_map_get($rev)) {
2329                        return ($rev, $c);
2330                }
2331                --$rev;
2332        }
2333        return (undef, undef);
2334}
2335
2336# Finds the first svn revision that exists on (if $eq_ok is true) or
2337# after $rev for the current branch.  It will not search any higher
2338# than $max_rev.  Returns the git commit hash and svn revision number
2339# if found, else (undef, undef).
2340sub find_rev_after {
2341        my ($self, $rev, $eq_ok, $max_rev) = @_;
2342        ++$rev unless $eq_ok;
2343        $max_rev ||= $self->rev_map_max;
2344        while ($rev <= $max_rev) {
2345                if (my $c = $self->rev_map_get($rev)) {
2346                        return ($rev, $c);
2347                }
2348                ++$rev;
2349        }
2350        return (undef, undef);
2351}
2352
2353sub _new {
2354        my ($class, $repo_id, $ref_id, $path) = @_;
2355        unless (defined $repo_id && length $repo_id) {
2356                $repo_id = $default_repo_id;
2357        }
2358        unless (defined $ref_id && length $ref_id) {
2359                # Access the prefix option from the git-svn main program if it's loaded.
2360                my $prefix = defined &::opt_prefix ? ::opt_prefix() : "";
2361                $_[2] = $ref_id =
2362                             "refs/remotes/$prefix$default_ref_id";
2363        }
2364        $_[1] = $repo_id;
2365        my $dir = "$ENV{GIT_DIR}/svn/$ref_id";
2366
2367        # Older repos imported by us used $GIT_DIR/svn/foo instead of
2368        # $GIT_DIR/svn/refs/remotes/foo when tracking refs/remotes/foo
2369        if ($ref_id =~ m{^refs/remotes/(.+)}) {
2370                my $old_dir = "$ENV{GIT_DIR}/svn/$1";
2371                if (-d $old_dir && ! -d $dir) {
2372                        $dir = $old_dir;
2373                }
2374        }
2375
2376        $_[3] = $path = '' unless (defined $path);
2377        mkpath([$dir]);
2378        my $obj = bless {
2379                ref_id => $ref_id, dir => $dir, index => "$dir/index",
2380                config => "$ENV{GIT_DIR}/svn/config",
2381                map_root => "$dir/.rev_map", repo_id => $repo_id }, $class;
2382
2383        # Ensure it gets canonicalized
2384        $obj->path($path);
2385
2386        return $obj;
2387}
2388
2389sub path {
2390        my $self = shift;
2391
2392        if (@_) {
2393                my $path = shift;
2394                $self->{_path} = canonicalize_path($path);
2395                return;
2396        }
2397
2398        return $self->{_path};
2399}
2400
2401sub url {
2402        my $self = shift;
2403
2404        if (@_) {
2405                my $url = shift;
2406                $self->{url} = canonicalize_url($url);
2407                return;
2408        }
2409
2410        return $self->{url};
2411}
2412
2413# for read-only access of old .rev_db formats
2414sub unlink_rev_db_symlink {
2415        my ($self) = @_;
2416        my $link = $self->rev_db_path;
2417        $link =~ s/\.[\w-]+$// or croak "missing UUID at the end of $link";
2418        if (-l $link) {
2419                unlink $link or croak "unlink: $link failed!";
2420        }
2421}
2422
2423sub rev_db_path {
2424        my ($self, $uuid) = @_;
2425        my $db_path = $self->map_path($uuid);
2426        $db_path =~ s{/\.rev_map\.}{/\.rev_db\.}
2427            or croak "map_path: $db_path does not contain '/.rev_map.' !";
2428        $db_path;
2429}
2430
2431# the new replacement for .rev_db
2432sub map_path {
2433        my ($self, $uuid) = @_;
2434        $uuid ||= $self->ra_uuid;
2435        "$self->{map_root}.$uuid";
2436}
2437
2438sub uri_encode {
2439        my ($f) = @_;
2440        $f =~ s#([^a-zA-Z0-9\*!\:_\./\-])#sprintf("%%%02X",ord($1))#eg;
2441        $f
2442}
2443
2444sub uri_decode {
2445        my ($f) = @_;
2446        $f =~ s#%([0-9a-fA-F]{2})#chr(hex($1))#eg;
2447        $f
2448}
2449
2450sub remove_username {
2451        $_[0] =~ s{^([^:]*://)[^@]+@}{$1};
2452}
2453
24541;