diff options
Diffstat (limited to 'perl')
| -rw-r--r-- | perl/Git.pm | 81 | ||||
| -rw-r--r-- | perl/Git/SVN.pm | 246 | ||||
| -rw-r--r-- | perl/Git/SVN/Editor.pm | 45 | ||||
| -rw-r--r-- | perl/Git/SVN/Fetcher.pm | 11 | ||||
| -rw-r--r-- | perl/Git/SVN/GlobSpec.pm | 18 | ||||
| -rw-r--r-- | perl/Git/SVN/Log.pm | 2 | ||||
| -rw-r--r-- | perl/Git/SVN/Ra.pm | 114 |
7 files changed, 390 insertions, 127 deletions
diff --git a/perl/Git.pm b/perl/Git.pm index 204fdc6737..ce7e4e8da3 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -188,7 +188,8 @@ sub repository { }; if ($dir) { - $dir =~ m#^/# or $dir = $opts{Directory} . '/' . $dir; + _verify_require(); + File::Spec->file_name_is_absolute($dir) or $dir = $opts{Directory} . '/' . $dir; $opts{Repository} = abs_path($dir); # If --git-dir went ok, this shouldn't die either. @@ -392,7 +393,7 @@ sub command_close_pipe { Execute the given C<COMMAND> in the same way as command_output_pipe() does but return both an input pipe filehandle and an output pipe filehandle. -The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>. +The function will return C<($pid, $pipe_in, $pipe_out, $ctx)>. See C<command_close_bidi_pipe()> for details. =cut @@ -695,7 +696,7 @@ Retrieve the integer configuration C<VARIABLE>. The return value is simple decimal number. An optional value suffix of 'k', 'm', or 'g' in the config file will cause the value to be multiplied by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output. -It would return C<undef> if configuration variable is not defined, +It would return C<undef> if configuration variable is not defined. =cut @@ -704,7 +705,7 @@ sub config_int { } # Common subroutine to implement bulk of what the config* family of methods -# do. This curently wraps command('config') so it is not so fast. +# do. This currently wraps command('config') so it is not so fast. sub _config_common { my ($opts) = shift @_; my ($self, $var) = _maybe_self(@_); @@ -864,6 +865,73 @@ sub ident_person { return "$ident[0] <$ident[1]>"; } +=item parse_mailboxes + +Return an array of mailboxes extracted from a string. + +=cut + +sub parse_mailboxes { + my $re_comment = qr/\((?:[^)]*)\)/; + my $re_quote = qr/"(?:[^\"\\]|\\.)*"/; + my $re_word = qr/(?:[^]["\s()<>:;@\\,.]|\\.)+/; + + # divide the string in tokens of the above form + my $re_token = qr/(?:$re_quote|$re_word|$re_comment|\S)/; + my @tokens = map { $_ =~ /\s*($re_token)\s*/g } @_; + + # add a delimiter to simplify treatment for the last mailbox + push @tokens, ","; + + my (@addr_list, @phrase, @address, @comment, @buffer) = (); + foreach my $token (@tokens) { + if ($token =~ /^[,;]$/) { + # if buffer still contains undeterminated strings + # append it at the end of @address or @phrase + if (@address) { + push @address, @buffer; + } else { + push @phrase, @buffer; + } + + my $str_phrase = join ' ', @phrase; + my $str_address = join '', @address; + my $str_comment = join ' ', @comment; + + # quote are necessary if phrase contains + # special characters + if ($str_phrase =~ /[][()<>:;@\\,.\000-\037\177]/) { + $str_phrase =~ s/(^|[^\\])"/$1/g; + $str_phrase = qq["$str_phrase"]; + } + + # add "<>" around the address if necessary + if ($str_address ne "" && $str_phrase ne "") { + $str_address = qq[<$str_address>]; + } + + my $str_mailbox = "$str_phrase $str_address $str_comment"; + $str_mailbox =~ s/^\s*|\s*$//g; + push @addr_list, $str_mailbox if ($str_mailbox); + + @phrase = @address = @comment = @buffer = (); + } elsif ($token =~ /^\(/) { + push @comment, $token; + } elsif ($token eq "<") { + push @phrase, (splice @address), (splice @buffer); + } elsif ($token eq ">") { + push @address, (splice @buffer); + } elsif ($token eq "@") { + push @address, (splice @buffer), "@"; + } elsif ($token eq ".") { + push @address, (splice @buffer), "."; + } else { + push @buffer, $token; + } + } + + return @addr_list; +} =item hash_object ( TYPE, FILENAME ) @@ -1294,8 +1362,11 @@ sub _temp_cache { $tmpdir = $self->repo_path(); } + my $n = $name; + $n =~ s/\W/_/g; # no strange chars + ($$temp_fd, $fname) = File::Temp::tempfile( - 'Git_XXXXXX', UNLINK => 1, DIR => $tmpdir, + "Git_${n}_XXXXXX", UNLINK => 1, DIR => $tmpdir, ) or throw Error::Simple("couldn't open new temp file"); $$temp_fd->autoflush; diff --git a/perl/Git/SVN.pm b/perl/Git/SVN.pm index a59564fb34..018beb85a0 100644 --- a/perl/Git/SVN.pm +++ b/perl/Git/SVN.pm @@ -9,11 +9,10 @@ use vars qw/$_no_metadata $_use_log_author $_add_author_from $_localtime/; use Carp qw/croak/; use File::Path qw/mkpath/; -use File::Copy qw/copy/; use IPC::Open3; use Memoize; # core since 5.8.0, Jul 2002 -use Memoize::Storable; use POSIX qw(:signal_h); +use Time::Local; use Git qw( command @@ -32,11 +31,7 @@ use Git::SVN::Utils qw( add_path_to_url ); -my $can_use_yaml; -BEGIN { - $can_use_yaml = eval { require Git::SVN::Memoize::YAML; 1}; -} - +my $memo_backend; our $_follow_parent = 1; our $_minimize_url = 'unset'; our $default_repo_id = 'svn'; @@ -103,6 +98,11 @@ sub resolve_local_globs { " globbed: $refname\n"; } my $u = (::cmt_metadata("$refname"))[0]; + if (!defined($u)) { + warn +"W: $refname: no associated commit metadata from SVN, skipping\n"; + next; + } $u =~ s!^\Q$url\E(/|$)!! or die "$refname: '$url' not found in '$u'\n"; if ($pathname ne $u) { @@ -1178,7 +1178,7 @@ sub find_parent_branch { or die "SVN connection failed somewhere...\n"; } print STDERR "Successfully followed parent\n" unless $::_q > 1; - return $self->make_log_entry($rev, [$parent], $ed); + return $self->make_log_entry($rev, [$parent], $ed, $r0, $branch_from); } return undef; } @@ -1210,26 +1210,93 @@ sub do_fetch { unless ($self->ra->gs_do_update($last_rev, $rev, $self, $ed)) { die "SVN connection failed somewhere...\n"; } - $self->make_log_entry($rev, \@parents, $ed); + $self->make_log_entry($rev, \@parents, $ed, $last_rev, $self->path); } sub mkemptydirs { my ($self, $r) = @_; + # add/remove/collect a paths table + # + # Paths are split into a tree of nodes, stored as a hash of hashes. + # + # Each node contains a 'path' entry for the path (if any) associated + # with that node and a 'children' entry for any nodes under that + # location. + # + # Removing a path requires a hash lookup for each component then + # dropping that node (and anything under it), which is substantially + # faster than a grep slice into a single hash of paths for large + # numbers of paths. + # + # For a large (200K) number of empty_dir directives this reduces + # scanning time to 3 seconds vs 10 minutes for grep+delete on a single + # hash of paths. + sub add_path { + my ($paths_table, $path) = @_; + my $node_ref; + + foreach my $x (split('/', $path)) { + if (!exists($paths_table->{$x})) { + $paths_table->{$x} = { children => {} }; + } + + $node_ref = $paths_table->{$x}; + $paths_table = $paths_table->{$x}->{children}; + } + + $node_ref->{path} = $path; + } + + sub remove_path { + my ($paths_table, $path) = @_; + my $nodes_ref; + my $node_name; + + foreach my $x (split('/', $path)) { + if (!exists($paths_table->{$x})) { + return; + } + + $nodes_ref = $paths_table; + $node_name = $x; + + $paths_table = $paths_table->{$x}->{children}; + } + + delete($nodes_ref->{$node_name}); + } + + sub collect_paths { + my ($paths_table, $paths_ref) = @_; + + foreach my $v (values %$paths_table) { + my $p = $v->{path}; + my $c = $v->{children}; + + collect_paths($c, $paths_ref); + + if (defined($p)) { + push(@$paths_ref, $p); + } + } + } + sub scan { - my ($r, $empty_dirs, $line) = @_; + my ($r, $paths_table, $line) = @_; if (defined $r && $line =~ /^r(\d+)$/) { return 0 if $1 > $r; } elsif ($line =~ /^ \+empty_dir: (.+)$/) { - $empty_dirs->{$1} = 1; + add_path($paths_table, $1); } elsif ($line =~ /^ \-empty_dir: (.+)$/) { - my @d = grep {m[^\Q$1\E(/|$)]} (keys %$empty_dirs); - delete @$empty_dirs{@d}; + remove_path($paths_table, $1); } 1; # continue }; - my %empty_dirs = (); + my @empty_dirs; + my %paths_table; + my $gz_file = "$self->{dir}/unhandled.log.gz"; if (-f $gz_file) { if (!can_compress()) { @@ -1240,7 +1307,7 @@ sub mkemptydirs { die "Unable to open $gz_file: $!\n"; my $line; while ($gz->gzreadline($line) > 0) { - scan($r, \%empty_dirs, $line) or last; + scan($r, \%paths_table, $line) or last; } $gz->gzclose; } @@ -1249,13 +1316,14 @@ sub mkemptydirs { if (open my $fh, '<', "$self->{dir}/unhandled.log") { binmode $fh or croak "binmode: $!"; while (<$fh>) { - scan($r, \%empty_dirs, $_) or last; + scan($r, \%paths_table, $_) or last; } close $fh; } + collect_paths(\%paths_table, \@empty_dirs); my $strip = qr/\A\Q@{[$self->path]}\E(?:\/|$)/; - foreach my $d (sort keys %empty_dirs) { + foreach my $d (sort @empty_dirs) { $d = uri_decode($d); $d =~ s/$strip//; next unless length($d); @@ -1321,7 +1389,7 @@ sub get_untracked { sub parse_svn_date { my $date = shift || return '+0000 1970-01-01 00:00:00'; my ($Y,$m,$d,$H,$M,$S) = ($date =~ /^(\d{4})\-(\d\d)\-(\d\d)T - (\d\d)\:(\d\d)\:(\d\d)\.\d*Z$/x) or + (\d\d?)\:(\d\d)\:(\d\d)\.\d*Z$/x) or croak "Unable to parse date: $date\n"; my $parsed_date; # Set next. @@ -1332,7 +1400,7 @@ sub parse_svn_date { $ENV{TZ} = 'UTC'; my $epoch_in_UTC = - POSIX::strftime('%s', $S, $M, $H, $d, $m - 1, $Y - 1900); + Time::Local::timelocal($S, $M, $H, $d, $m - 1, $Y - 1900); # Determine our local timezone (including DST) at the # time of $epoch_in_UTC. $Git::SVN::Log::TZ stored the @@ -1433,7 +1501,7 @@ sub check_author { } sub find_extra_svk_parents { - my ($self, $ed, $tickets, $parents) = @_; + my ($self, $tickets, $parents) = @_; # aha! svk:merge property changed... my @tickets = split "\n", $tickets; my @known_parents; @@ -1478,9 +1546,9 @@ sub find_extra_svk_parents { sub lookup_svn_merge { my $uuid = shift; my $url = shift; - my $merge = shift; + my $source = shift; + my $revs = shift; - my ($source, $revs) = split ":", $merge; my $path = $source; $path =~ s{^/}{}; my $gs = Git::SVN->find_by_url($url.$source, $url, $path); @@ -1537,7 +1605,7 @@ sub _rev_list { @rv; } -sub check_cherry_pick { +sub check_cherry_pick2 { my $base = shift; my $tip = shift; my $parents = shift; @@ -1552,7 +1620,8 @@ sub check_cherry_pick { delete $commits{$commit}; } } - return (keys %commits); + my @k = (keys %commits); + return (scalar @k, $k[0]); } sub has_no_changes { @@ -1577,7 +1646,16 @@ sub tie_for_persistent_memoization { my $hash = shift; my $path = shift; - if ($can_use_yaml) { + unless ($memo_backend) { + if (eval { require Git::SVN::Memoize::YAML; 1}) { + $memo_backend = 1; + } else { + require Memoize::Storable; + $memo_backend = -1; + } + } + + if ($memo_backend > 0) { tie %$hash => 'Git::SVN::Memoize::YAML', "$path.yaml"; } else { tie %$hash => 'Memoize::Storable', "$path.db", 'nstore'; @@ -1597,9 +1675,8 @@ sub tie_for_persistent_memoization { mkpath([$cache_path]) unless -d $cache_path; my %lookup_svn_merge_cache; - my %check_cherry_pick_cache; + my %check_cherry_pick2_cache; my %has_no_changes_cache; - my %_rev_list_cache; tie_for_persistent_memoization(\%lookup_svn_merge_cache, "$cache_path/lookup_svn_merge"); @@ -1608,11 +1685,11 @@ sub tie_for_persistent_memoization { LIST_CACHE => ['HASH' => \%lookup_svn_merge_cache], ; - tie_for_persistent_memoization(\%check_cherry_pick_cache, - "$cache_path/check_cherry_pick"); - memoize 'check_cherry_pick', + tie_for_persistent_memoization(\%check_cherry_pick2_cache, + "$cache_path/check_cherry_pick2"); + memoize 'check_cherry_pick2', SCALAR_CACHE => 'FAULT', - LIST_CACHE => ['HASH' => \%check_cherry_pick_cache], + LIST_CACHE => ['HASH' => \%check_cherry_pick2_cache], ; tie_for_persistent_memoization(\%has_no_changes_cache, @@ -1621,14 +1698,6 @@ sub tie_for_persistent_memoization { SCALAR_CACHE => ['HASH' => \%has_no_changes_cache], LIST_CACHE => 'FAULT', ; - - tie_for_persistent_memoization(\%_rev_list_cache, - "$cache_path/_rev_list"); - memoize '_rev_list', - SCALAR_CACHE => 'FAULT', - LIST_CACHE => ['HASH' => \%_rev_list_cache], - ; - } sub unmemoize_svn_mergeinfo_functions { @@ -1636,9 +1705,8 @@ sub tie_for_persistent_memoization { $memoized = 0; Memoize::unmemoize 'lookup_svn_merge'; - Memoize::unmemoize 'check_cherry_pick'; + Memoize::unmemoize 'check_cherry_pick2'; Memoize::unmemoize 'has_no_changes'; - Memoize::unmemoize '_rev_list'; } sub clear_memoized_mergeinfo_caches { @@ -1648,7 +1716,8 @@ sub tie_for_persistent_memoization { return unless -d $cache_path; for my $cache_file (("$cache_path/lookup_svn_merge", - "$cache_path/check_cherry_pick", + "$cache_path/check_cherry_pick", # old + "$cache_path/check_cherry_pick2", "$cache_path/has_no_changes")) { for my $suffix (qw(yaml db)) { my $file = "$cache_file.$suffix"; @@ -1702,11 +1771,49 @@ sub parents_exclude { return @excluded; } +# Compute what's new in svn:mergeinfo. +sub mergeinfo_changes { + my ($self, $old_path, $old_rev, $path, $rev, $mergeinfo_prop) = @_; + my %minfo = map {split ":", $_ } split "\n", $mergeinfo_prop; + my $old_minfo = {}; + + my $ra = $self->ra; + # Give up if $old_path isn't in the repo. + # This is probably a merge on a subtree. + if ($ra->check_path($old_path, $old_rev) != $SVN::Node::dir) { + warn "W: ignoring svn:mergeinfo on $old_path, ", + "directory didn't exist in r$old_rev\n"; + return {}; + } + my (undef, undef, $props) = $ra->get_dir($old_path, $old_rev); + if (defined $props->{"svn:mergeinfo"}) { + my %omi = map {split ":", $_ } split "\n", + $props->{"svn:mergeinfo"}; + $old_minfo = \%omi; + } + + my %changes = (); + foreach my $p (keys %minfo) { + my $a = $old_minfo->{$p} || ""; + my $b = $minfo{$p}; + # Omit merged branches whose ranges lists are unchanged. + next if $a eq $b; + # Remove any common range list prefix. + ($a ^ $b) =~ /^[\0]*/; + my $common_prefix = rindex $b, ",", $+[0] - 1; + $changes{$p} = substr $b, $common_prefix + 1; + } + print STDERR "Checking svn:mergeinfo changes since r$old_rev: ", + scalar(keys %minfo), " sources, ", + scalar(keys %changes), " changed\n"; + + return \%changes; +} # note: this function should only be called if the various dirprops # have actually changed sub find_extra_svn_parents { - my ($self, $ed, $mergeinfo, $parents) = @_; + my ($self, $mergeinfo, $parents) = @_; # aha! svk:merge property changed... memoize_svn_mergeinfo_functions(); @@ -1715,14 +1822,15 @@ sub find_extra_svn_parents { # history. Then, we figure out which git revisions are in # that tip, but not this revision. If all of those revisions # are now marked as merge, we can add the tip as a parent. - my @merges = split "\n", $mergeinfo; + my @merges = sort keys %$mergeinfo; my @merge_tips; my $url = $self->url; my $uuid = $self->ra_uuid; my @all_ranges; for my $merge ( @merges ) { my ($tip_commit, @ranges) = - lookup_svn_merge( $uuid, $url, $merge ); + lookup_svn_merge( $uuid, $url, + $merge, $mergeinfo->{$merge} ); unless (!$tip_commit or grep { $_ eq $tip_commit } @$parents ) { push @merge_tips, $tip_commit; @@ -1738,8 +1846,9 @@ sub find_extra_svn_parents { # check merge tips for new parents my @new_parents; for my $merge_tip ( @merge_tips ) { - my $spec = shift @merges; + my $merge = shift @merges; next unless $merge_tip and $excluded{$merge_tip}; + my $spec = "$merge:$mergeinfo->{$merge}"; # check out 'new' tips my $merge_base; @@ -1759,19 +1868,17 @@ sub find_extra_svn_parents { } # double check that there are no missing non-merge commits - my (@incomplete) = check_cherry_pick( + my ($ninc, $ifirst) = check_cherry_pick2( $merge_base, $merge_tip, $parents, @all_ranges, ); - if ( @incomplete ) { - warn "W:svn cherry-pick ignored ($spec) - missing " - .@incomplete." commit(s) (eg $incomplete[0])\n"; + if ($ninc) { + warn "W: svn cherry-pick ignored ($spec) - missing " . + "$ninc commit(s) (eg $ifirst)\n"; } else { - warn - "Found merge parent (svn:mergeinfo prop): ", - $merge_tip, "\n"; + warn "Found merge parent ($spec): ", $merge_tip, "\n"; push @new_parents, $merge_tip; } } @@ -1797,22 +1904,26 @@ sub find_extra_svn_parents { } sub make_log_entry { - my ($self, $rev, $parents, $ed) = @_; + my ($self, $rev, $parents, $ed, $parent_rev, $parent_path) = @_; my $untracked = $self->get_untracked($ed); my @parents = @$parents; - my $ps = $ed->{path_strip} || ""; - for my $path ( grep { m/$ps/ } %{$ed->{dir_prop}} ) { - my $props = $ed->{dir_prop}{$path}; - if ( $props->{"svk:merge"} ) { - $self->find_extra_svk_parents - ($ed, $props->{"svk:merge"}, \@parents); + my $props = $ed->{dir_prop}{$self->path}; + if ($self->follow_parent) { + my $tickets = $props->{"svk:merge"}; + if ($tickets) { + $self->find_extra_svk_parents($tickets, \@parents); } - if ( $props->{"svn:mergeinfo"} ) { - $self->find_extra_svn_parents - ($ed, - $props->{"svn:mergeinfo"}, - \@parents); + + my $mergeinfo_prop = $props->{"svn:mergeinfo"}; + if ($mergeinfo_prop) { + my $mi_changes = $self->mergeinfo_changes( + $parent_path, + $parent_rev, + $self->path, + $rev, + $mergeinfo_prop); + $self->find_extra_svn_parents($mi_changes, \@parents); } } @@ -2161,8 +2272,9 @@ sub rev_map_set { # both of these options make our .rev_db file very, very important # and we can't afford to lose it because rebuild() won't work if ($self->use_svm_props || $self->no_metadata) { + require File::Copy; $sync = 1; - copy($db, $db_lock) or die "rev_map_set(@_): ", + File::Copy::copy($db, $db_lock) or die "rev_map_set(@_): ", "Failed to copy: ", "$db => $db_lock ($!)\n"; } else { @@ -2338,7 +2450,7 @@ sub _new { # Older repos imported by us used $GIT_DIR/svn/foo instead of # $GIT_DIR/svn/refs/remotes/foo when tracking refs/remotes/foo - if ($ref_id =~ m{^refs/remotes/(.*)}) { + if ($ref_id =~ m{^refs/remotes/(.+)}) { my $old_dir = "$ENV{GIT_DIR}/svn/$1"; if (-d $old_dir && ! -d $dir) { $dir = $old_dir; diff --git a/perl/Git/SVN/Editor.pm b/perl/Git/SVN/Editor.pm index 34e8af966c..4c4199afec 100644 --- a/perl/Git/SVN/Editor.pm +++ b/perl/Git/SVN/Editor.pm @@ -5,7 +5,6 @@ use warnings; use SVN::Core; use SVN::Delta; use Carp qw/croak/; -use IO::File; use Git qw/command command_oneline command_noisy command_output_pipe command_input_pipe command_close_pipe command_bidi_pipe command_close_bidi_pipe/; @@ -42,6 +41,7 @@ sub new { "$self->{svn_path}/" : ''; $self->{config} = $opts->{config}; $self->{mergeinfo} = $opts->{mergeinfo}; + $self->{pathnameencoding} = Git::config('svn.pathnameencoding'); return $self; } @@ -144,11 +144,12 @@ sub repo_path { sub url_path { my ($self, $path) = @_; + $path = $self->repo_path($path); if ($self->{url} =~ m#^https?://#) { # characters are taken from subversion/libsvn_subr/path.c $path =~ s#([^~a-zA-Z0-9_./!$&'()*+,-])#sprintf("%%%02X",ord($1))#eg; } - $self->{url} . '/' . $self->repo_path($path); + $self->{url} . '/' . $path; } sub rmdirs { @@ -288,6 +289,40 @@ sub apply_autoprops { } } +sub check_attr { + my ($attr,$path) = @_; + my $val = command_oneline("check-attr", $attr, "--", $path); + if ($val) { $val =~ s/^[^:]*:\s*[^:]*:\s*(.*)\s*$/$1/; } + return $val; +} + +sub apply_manualprops { + my ($self, $file, $fbat) = @_; + my $pending_properties = check_attr( "svn-properties", $file ); + if ($pending_properties eq "") { return; } + # Parse the list of properties to set. + my @props = split(/;/, $pending_properties); + # TODO: get existing properties to compare to + # - this fails for add so currently not done + # my $existing_props = ::get_svnprops($file); + my $existing_props = {}; + # TODO: caching svn properties or storing them in .gitattributes + # would make that faster + foreach my $prop (@props) { + # Parse 'name=value' syntax and set the property. + if ($prop =~ /([^=]+)=(.*)/) { + my ($n,$v) = ($1,$2); + for ($n, $v) { + s/^\s+//; s/\s+$//; + } + my $existing = $existing_props->{$n}; + if (!defined($existing) || $existing ne $v) { + $self->change_file_prop($fbat, $n, $v); + } + } + } +} + sub A { my ($self, $m, $deletions) = @_; my ($dir, $file) = split_path($m->{file_b}); @@ -296,6 +331,7 @@ sub A { undef, -1); print "\tA\t$m->{file_b}\n" unless $::_q; $self->apply_autoprops($file, $fbat); + $self->apply_manualprops($m->{file_b}, $fbat); $self->chg_file($fbat, $m); $self->close_file($fbat,undef,$self->{pool}); } @@ -311,6 +347,7 @@ sub C { my $fbat = $self->add_file($self->repo_path($m->{file_b}), $pbat, $upa, $self->{r}); print "\tC\t$m->{file_a} => $m->{file_b}\n" unless $::_q; + $self->apply_manualprops($m->{file_b}, $fbat); $self->chg_file($fbat, $m); $self->close_file($fbat,undef,$self->{pool}); } @@ -333,6 +370,7 @@ sub R { $upa, $self->{r}); print "\tR\t$m->{file_a} => $m->{file_b}\n" unless $::_q; $self->apply_autoprops($file, $fbat); + $self->apply_manualprops($m->{file_b}, $fbat); $self->chg_file($fbat, $m); $self->close_file($fbat,undef,$self->{pool}); @@ -348,6 +386,7 @@ sub M { my $fbat = $self->open_file($self->repo_path($m->{file_b}), $pbat,$self->{r},$self->{pool}); print "\t$m->{chg}\t$m->{file_b}\n" unless $::_q; + $self->apply_manualprops($m->{file_b}, $fbat); $self->chg_file($fbat, $m); $self->close_file($fbat,undef,$self->{pool}); } @@ -548,7 +587,7 @@ The interface will change as git-svn evolves. =head1 DEPENDENCIES Subversion perl bindings, -the core L<Carp> and L<IO::File> modules, +the core L<Carp> module, and git's L<Git> helper module. C<Git::SVN::Editor> has not been tested using callers other than diff --git a/perl/Git/SVN/Fetcher.pm b/perl/Git/SVN/Fetcher.pm index 10edb27732..d8c21ad915 100644 --- a/perl/Git/SVN/Fetcher.pm +++ b/perl/Git/SVN/Fetcher.pm @@ -7,7 +7,6 @@ use warnings; use SVN::Delta; use Carp qw/croak/; use File::Basename qw/dirname/; -use IO::File qw//; use Git qw/command command_oneline command_noisy command_output_pipe command_input_pipe command_close_pipe command_bidi_pipe command_close_bidi_pipe/; @@ -322,6 +321,14 @@ sub apply_textdelta { # (but $base does not,) so dup() it for reading in close_file open my $dup, '<&', $fh or croak $!; my $base = $::_repository->temp_acquire("git_blob_${$}_$suffix"); + # close_file may call temp_acquire on 'svn_hash', but because of the + # call chain, if the temp_acquire call from close_file ends up being the + # call that first creates the 'svn_hash' temp file, then the FileHandle + # that's created as a result will end up in an SVN::Pool that we clear + # in SVN::Ra::gs_fetch_loop_common. Avoid that by making sure the + # 'svn_hash' FileHandle is already created before close_file is called. + my $tmp_fh = $::_repository->temp_acquire('svn_hash'); + $::_repository->temp_release($tmp_fh, 1); if ($fb->{blob}) { my ($base_is_link, $size); @@ -600,7 +607,7 @@ developing git-svn. =head1 DEPENDENCIES L<SVN::Delta> from the Subversion perl bindings, -the core L<Carp>, L<File::Basename>, and L<IO::File> modules, +the core L<Carp> and L<File::Basename> modules, and git's L<Git> helper module. C<Git::SVN::Fetcher> has not been tested using callers other than diff --git a/perl/Git/SVN/GlobSpec.pm b/perl/Git/SVN/GlobSpec.pm index c95f5d76ca..a0a8d17621 100644 --- a/perl/Git/SVN/GlobSpec.pm +++ b/perl/Git/SVN/GlobSpec.pm @@ -8,19 +8,23 @@ sub new { $re =~ s!/+$!!g; # no need for trailing slashes my (@left, @right, @patterns); my $state = "left"; - my $die_msg = "Only one set of wildcard directories " . - "(e.g. '*' or '*/*/*') is supported: '$glob'\n"; + my $die_msg = "Only one set of wildcards " . + "(e.g. '*' or '*/*/*') is supported: $glob\n"; for my $part (split(m|/|, $glob)) { - if ($part =~ /\*/ && $part ne "*") { - die "Invalid pattern in '$glob': $part\n"; - } elsif ($pattern_ok && $part =~ /[{}]/ && + if ($pattern_ok && $part =~ /[{}]/ && $part !~ /^\{[^{}]+\}/) { die "Invalid pattern in '$glob': $part\n"; } - if ($part eq "*") { + my $nstars = $part =~ tr/*//; + if ($nstars > 1) { + die "Only one '*' is allowed in a pattern: '$part'\n"; + } + if ($part =~ /(.*)\*(.*)/) { die $die_msg if $state eq "right"; + my ($l, $r) = ($1, $2); $state = "pattern"; - push(@patterns, "[^/]*"); + my $pat = quotemeta($l) . '[^/]*' . quotemeta($r); + push(@patterns, $pat); } elsif ($pattern_ok && $part =~ /^\{(.*)\}$/) { die $die_msg if $state eq "right"; $state = "pattern"; diff --git a/perl/Git/SVN/Log.pm b/perl/Git/SVN/Log.pm index 34f2869ab5..664105357c 100644 --- a/perl/Git/SVN/Log.pm +++ b/perl/Git/SVN/Log.pm @@ -116,7 +116,7 @@ sub run_pager { return; } open STDIN, '<&', $rfd or fatal "Can't redirect stdin: $!"; - $ENV{LESS} ||= 'FRSX'; + $ENV{LESS} ||= 'FRX'; $ENV{LV} ||= '-c'; exec $pager or fatal "Can't run pager: $! ($pager)"; } diff --git a/perl/Git/SVN/Ra.pm b/perl/Git/SVN/Ra.pm index a7b0119ee5..e764696801 100644 --- a/perl/Git/SVN/Ra.pm +++ b/perl/Git/SVN/Ra.pm @@ -2,7 +2,7 @@ package Git::SVN::Ra; use vars qw/@ISA $config_dir $_ignore_refs_regex $_log_window_size/; use strict; use warnings; -use SVN::Client; +use Memoize; use Git::SVN::Utils qw( canonicalize_url canonicalize_path @@ -41,6 +41,7 @@ END { } sub _auth_providers () { + require SVN::Client; my @rv = ( SVN::Client::get_simple_provider(), SVN::Client::get_ssl_server_trust_file_provider(), @@ -76,6 +77,44 @@ sub _auth_providers () { \@rv; } +sub prepare_config_once { + SVN::_Core::svn_config_ensure($config_dir, undef); + my ($baton, $callbacks) = SVN::Core::auth_open_helper(_auth_providers); + my $config = SVN::Core::config_get_config($config_dir); + my $conf_t = $config->{'config'}; + + no warnings 'once'; + # The usage of $SVN::_Core::SVN_CONFIG_* variables + # produces warnings that variables are used only once. + # I had not found the better way to shut them up, so + # the warnings of type 'once' are disabled in this block. + if (SVN::_Core::svn_config_get_bool($conf_t, + $SVN::_Core::SVN_CONFIG_SECTION_AUTH, + $SVN::_Core::SVN_CONFIG_OPTION_STORE_PASSWORDS, + 1) == 0) { + my $val = '1'; + if (::compare_svn_version('1.9.0') < 0) { # pre-SVN r1553823 + my $dont_store_passwords = 1; + $val = bless \$dont_store_passwords, "_p_void"; + } + SVN::_Core::svn_auth_set_parameter($baton, + $SVN::_Core::SVN_AUTH_PARAM_DONT_STORE_PASSWORDS, + $val); + } + if (SVN::_Core::svn_config_get_bool($conf_t, + $SVN::_Core::SVN_CONFIG_SECTION_AUTH, + $SVN::_Core::SVN_CONFIG_OPTION_STORE_AUTH_CREDS, + 1) == 0) { + $Git::SVN::Prompt::_no_auth_cache = 1; + } + + return ($config, $baton, $callbacks); +} # no warnings 'once' + +INIT { + Memoize::memoize '_auth_providers'; + Memoize::memoize 'prepare_config_once'; +} sub new { my ($class, $url) = @_; @@ -84,34 +123,8 @@ sub new { ::_req_svn(); - SVN::_Core::svn_config_ensure($config_dir, undef); - my ($baton, $callbacks) = SVN::Core::auth_open_helper(_auth_providers); - my $config = SVN::Core::config_get_config($config_dir); $RA = undef; - my $dont_store_passwords = 1; - my $conf_t = ${$config}{'config'}; - { - no warnings 'once'; - # The usage of $SVN::_Core::SVN_CONFIG_* variables - # produces warnings that variables are used only once. - # I had not found the better way to shut them up, so - # the warnings of type 'once' are disabled in this block. - if (SVN::_Core::svn_config_get_bool($conf_t, - $SVN::_Core::SVN_CONFIG_SECTION_AUTH, - $SVN::_Core::SVN_CONFIG_OPTION_STORE_PASSWORDS, - 1) == 0) { - SVN::_Core::svn_auth_set_parameter($baton, - $SVN::_Core::SVN_AUTH_PARAM_DONT_STORE_PASSWORDS, - bless (\$dont_store_passwords, "_p_void")); - } - if (SVN::_Core::svn_config_get_bool($conf_t, - $SVN::_Core::SVN_CONFIG_SECTION_AUTH, - $SVN::_Core::SVN_CONFIG_OPTION_STORE_AUTH_CREDS, - 1) == 0) { - $Git::SVN::Prompt::_no_auth_cache = 1; - } - } # no warnings 'once' - + my ($config, $baton, $callbacks) = prepare_config_once(); my $self = SVN::Ra->new(url => $url, auth => $baton, config => $config, pool => SVN::Pool->new, @@ -166,7 +179,17 @@ sub get_dir { } } my $pool = SVN::Pool->new; - my ($d, undef, $props) = $self->SUPER::get_dir($dir, $r, $pool); + my ($d, undef, $props); + + if (::compare_svn_version('1.4.0') >= 0) { + # n.b. in addition to being potentially more efficient, + # this works around what appears to be a bug in some + # SVN 1.8 versions + my $kind = 1; # SVN_DIRENT_KIND + ($d, undef, $props) = $self->get_dir2($dir, $r, $kind, $pool); + } else { + ($d, undef, $props) = $self->SUPER::get_dir($dir, $r, $pool); + } my %dirents = map { $_ => { kind => $d->{$_}->kind } } keys %$d; $pool->clear; if ($r != $cache->{r}) { @@ -177,10 +200,6 @@ sub get_dir { wantarray ? (\%dirents, $r, $props) : \%dirents; } -sub DESTROY { - # do not call the real DESTROY since we store ourselves in $RA -} - # get_log(paths, start, end, limit, # discover_changed_paths, strict_node_history, receiver) sub get_log { @@ -232,7 +251,10 @@ sub get_log { $ret; } +# uncommon, only for ancient SVN (<= 1.4.2) sub trees_match { + require IO::File; + require SVN::Client; my ($self, $url1, $rev1, $url2, $rev2) = @_; my $ctx = SVN::Client->new(auth => _auth_providers); my $out = IO::File->new_tmpfile; @@ -376,10 +398,22 @@ sub longest_common_path { sub gs_fetch_loop_common { my ($self, $base, $head, $gsv, $globs) = @_; return if ($base > $head); + # Make sure the cat_blob open2 FileHandle is created before calling + # SVN::Pool::new_default so that it does not incorrectly end up in the pool. + $::_repository->_open_cat_blob_if_needed; + my $gpool = SVN::Pool->new_default; + my $ra_url = $self->url; + my $reload_ra = sub { + $_[0] = undef; + $self = undef; + $RA = undef; + $gpool->clear; + $self = Git::SVN::Ra->new($ra_url); + $ra_invalid = undef; + }; my $inc = $_log_window_size; my ($min, $max) = ($base, $head < $base + $inc ? $head : $base + $inc); my $longest_path = longest_common_path($gsv, $globs); - my $ra_url = $self->url; my $find_trailing_edge; while (1) { my %revs; @@ -426,7 +460,7 @@ sub gs_fetch_loop_common { my %exists = map { $_->path => $_ } @$gsv; foreach my $r (sort {$a <=> $b} keys %revs) { - my ($paths, $logged) = @{$revs{$r}}; + my ($paths, $logged) = @{delete $revs{$r}}; foreach my $gs ($self->match_globs(\%exists, $paths, $globs, $r)) { @@ -449,13 +483,7 @@ sub gs_fetch_loop_common { "$g->{t}-maxRev"; Git::SVN::tmp_config($k, $r); } - if ($ra_invalid) { - $_[0] = undef; - $self = undef; - $RA = undef; - $self = Git::SVN::Ra->new($ra_url); - $ra_invalid = undef; - } + $reload_ra->() if $ra_invalid; } # pre-fill the .rev_db since it'll eventually get filled in # with '0' x40 if something new gets committed @@ -472,6 +500,8 @@ sub gs_fetch_loop_common { $min = $max + 1; $max += $inc; $max = $head if ($max > $head); + + $reload_ra->(); } Git::SVN::gc(); } |