diff options
Diffstat (limited to 'git-svn.perl')
| -rwxr-xr-x | git-svn.perl | 556 |
1 files changed, 504 insertions, 52 deletions
diff --git a/git-svn.perl b/git-svn.perl index eb4b75aff3..473a0b9d55 100755 --- a/git-svn.perl +++ b/git-svn.perl @@ -26,6 +26,7 @@ if (! exists $ENV{SVN_SSH}) { $ENV{SVN_SSH} = $ENV{GIT_SSH}; if ($^O eq 'msys') { $ENV{SVN_SSH} =~ s/\\/\\\\/g; + $ENV{SVN_SSH} =~ s/(.*)/"$1"/; } } } @@ -115,6 +116,7 @@ my %init_opts = ( 'template=s' => \$_template, 'shared:s' => \$_shared, 'use-svm-props' => sub { $icv{useSvmProps} = 1 }, 'use-svnsync-props' => sub { $icv{useSvnsyncProps} = 1 }, 'rewrite-root=s' => sub { $icv{rewriteRoot} = $_[1] }, + 'rewrite-uuid=s' => sub { $icv{rewriteUUID} = $_[1] }, %remote_opts ); my %cmt_opts = ( 'edit|e' => \$_edit, 'rmdir' => \$SVN::Git::Editor::_rmdir, @@ -155,12 +157,16 @@ my %cmd = ( { 'message|m=s' => \$_message, 'destination|d=s' => \$_branch_dest, 'dry-run|n' => \$_dry_run, - 'tag|t' => \$_tag } ], + 'tag|t' => \$_tag, + 'username=s' => \$Git::SVN::Prompt::_username, + 'commit-url=s' => \$_commit_url } ], tag => [ sub { $_tag = 1; cmd_branch(@_) }, 'Create a tag in the SVN repository', { 'message|m=s' => \$_message, 'destination|d=s' => \$_branch_dest, - 'dry-run|n' => \$_dry_run } ], + 'dry-run|n' => \$_dry_run, + 'username=s' => \$Git::SVN::Prompt::_username, + 'commit-url=s' => \$_commit_url } ], 'set-tree' => [ \&cmd_set_tree, "Set an SVN repository to a git tree-ish", { 'stdin' => \$_stdin, %cmt_opts, %fc_opts, } ], @@ -168,6 +174,9 @@ my %cmd = ( 'Create a .gitignore per svn:ignore', { 'revision|r=i' => \$_revision } ], + 'mkdirs' => [ \&cmd_mkdirs , + "recreate empty directories after a checkout", + { 'revision|r=i' => \$_revision } ], 'propget' => [ \&cmd_propget, 'Print the value of a property on a file or directory', { 'revision|r=i' => \$_revision } ], @@ -274,7 +283,7 @@ unless ($cmd && $cmd =~ /(?:clone|init|multi-init)$/) { my %opts = %{$cmd{$cmd}->[2]} if (defined $cmd); -read_repo_config(\%opts); +read_git_config(\%opts); if ($cmd && ($cmd eq 'log' || $cmd eq 'blame')) { Getopt::Long::Configure('pass_through'); } @@ -389,9 +398,11 @@ sub cmd_clone { $path = $url; } $path = basename($url) if !defined $path || !length $path; + my $authors_absolute = $_authors ? File::Spec->rel2abs($_authors) : ""; cmd_init($url, $path); + command_oneline('config', 'svn.authorsfile', $authors_absolute) + if $_authors; Git::SVN::fetch_all($Git::SVN::default_repo_id); - command_oneline('config', 'svn.authorsfile', $_authors) if $_authors; } sub cmd_init { @@ -425,6 +436,7 @@ sub cmd_fetch { if (@_ > 1) { die "Usage: $0 fetch [--all] [--parent] [svn-remote]\n"; } + $Git::SVN::no_reuse_existing = undef; if ($_fetch_parent) { my ($url, $rev, $uuid, $gs) = working_head_info('HEAD'); unless ($gs) { @@ -657,7 +669,8 @@ sub cmd_branch { } $head ||= 'HEAD'; - my ($src, $rev, undef, $gs) = working_head_info($head); + my (undef, $rev, undef, $gs) = working_head_info($head); + my $src = $gs->full_url; my $remote = Git::SVN::read_all_remotes()->{$gs->{repo_id}}; my $allglobs = $remote->{ $_tag ? 'tags' : 'branches' }; @@ -701,7 +714,21 @@ sub cmd_branch { } } my ($lft, $rgt) = @{ $glob->{path} }{qw/left right/}; - my $dst = join '/', $remote->{url}, $lft, $branch_name, ($rgt || ()); + my $url; + if (defined $_commit_url) { + $url = $_commit_url; + } else { + $url = eval { command_oneline('config', '--get', + "svn-remote.$gs->{repo_id}.commiturl") }; + if (!$url) { + $url = $remote->{url}; + } + } + my $dst = join '/', $url, $lft, $branch_name, ($rgt || ()); + + if ($dst =~ /^https:/ && $src =~ /^http:/) { + $src=~s/^http:/https:/; + } my $ctx = SVN::Client->new( auth => Git::SVN::Ra::_auth_providers(), @@ -769,6 +796,7 @@ sub cmd_rebase { $_fetch_all ? $gs->fetch_all : $gs->fetch; } command_noisy(rebase_cmd(), $gs->refname); + $gs->mkemptydirs; } sub cmd_show_ignore { @@ -830,6 +858,12 @@ sub cmd_create_ignore { }); } +sub cmd_mkdirs { + my ($url, $rev, $uuid, $gs) = working_head_info('HEAD'); + $gs ||= Git::SVN->new; + $gs->mkemptydirs($_revision); +} + sub canonicalize_path { my ($path) = @_; my $dot_slash_added = 0; @@ -946,6 +980,7 @@ sub cmd_multi_init { } sub cmd_multi_fetch { + $Git::SVN::no_reuse_existing = undef; my $remotes = Git::SVN::read_all_remotes(); foreach my $repo_id (sort keys %$remotes) { if ($remotes->{$repo_id}->{url}) { @@ -1196,6 +1231,7 @@ sub post_fetch_checkout { command_noisy(qw/read-tree -m -u -v HEAD HEAD/); print STDERR "Checked out HEAD:\n ", $gs->full_url, " r", $gs->last_rev, "\n"; + $gs->mkemptydirs($gs->last_rev); } sub complete_svn_url { @@ -1321,9 +1357,8 @@ sub get_commit_entry { close $log_fh or croak $!; if ($_edit || ($type eq 'tree')) { - my $editor = $ENV{VISUAL} || $ENV{EDITOR} || 'vi'; - # TODO: strip out spaces, comments, like git-commit.sh - system($editor, $commit_editmsg); + chomp(my $editor = command_oneline(qw(var GIT_EDITOR))); + system('sh', '-c', $editor.' "$@"', $editor, $commit_editmsg); } rename $commit_editmsg, $commit_msg or croak $!; { @@ -1390,8 +1425,7 @@ sub load_authors { } # convert GetOpt::Long specs for use by git-config -sub read_repo_config { - return unless -d $ENV{GIT_DIR}; +sub read_git_config { my $opts = shift; my @config_only; foreach my $o (keys %$opts) { @@ -1621,6 +1655,8 @@ 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; my ($_gc_nr, $_gc_period); @@ -1728,7 +1764,11 @@ sub fetch_all { my $ra = Git::SVN::Ra->new($url); my $uuid = $ra->get_uuid; my $head = $ra->get_latest_revnum; - $ra->get_log("", $head, 0, 1, 0, 1, sub { $head = $_[1] }); + + # ignore errors, $head revision may not even exist anymore + eval { $ra->get_log("", $head, 0, 1, 0, 1, sub { $head = $_[1] }) }; + warn "W: $@\n" if $@; + my $base = defined $fetch ? $head : 0; # read the max revs for wildcard expansion (branches/*, tags/*) @@ -1765,7 +1805,7 @@ sub read_all_remotes { my $use_svm_props = eval { command_oneline(qw/config --bool svn.useSvmProps/) }; $use_svm_props = $use_svm_props eq 'true' if $use_svm_props; - my $svn_refspec = qr{\s*/?(.*?)\s*:\s*(.+?)\s*}; + my $svn_refspec = qr{\s*(.*?)\s*:\s*(.+?)\s*}; foreach (grep { s/^svn-remote\.// } command(qw/config -l/)) { if (m!^(.+)\.fetch=$svn_refspec$!) { my ($remote, $local_ref, $remote_ref) = ($1, $2, $3); @@ -1787,8 +1827,8 @@ sub read_all_remotes { my $rs = { t => $t, remote => $remote, - path => Git::SVN::GlobSpec->new($local_ref), - ref => Git::SVN::GlobSpec->new($remote_ref) }; + path => Git::SVN::GlobSpec->new($local_ref, 1), + ref => Git::SVN::GlobSpec->new($remote_ref, 0) }; if (length($rs->{ref}->{right}) != 0) { die "The '*' glob character must be the last ", "character of '$remote_ref'\n"; @@ -1979,7 +2019,7 @@ sub find_ref { my ($ref_id) = @_; foreach (command(qw/config -l/)) { next unless m!^svn-remote\.(.+)\.fetch= - \s*/?(.*?)\s*:\s*(.+?)\s*$!x; + \s*(.*?)\s*:\s*(.+?)\s*$!x; my ($repo_id, $path, $ref) = ($1, $2, $3); if ($ref eq $ref_id) { $path = '' if ($path =~ m#^\./?#); @@ -2170,6 +2210,10 @@ sub svnsync { die "Can't have both 'useSvnsyncProps' and 'rewriteRoot' ", "options set!\n"; } + if ($self->rewrite_uuid) { + die "Can't have both 'useSvnsyncProps' and 'rewriteUUID' ", + "options set!\n"; + } my $svnsync; # see if we have it in our config, first: @@ -2433,12 +2477,6 @@ sub get_commit_parents { next if $seen{$p}; $seen{$p} = 1; push @ret, $p; - # MAXPARENT is defined to 16 in commit-tree.c: - last if @ret >= 16; - } - if (@tmp) { - die "r$log_entry->{revision}: No room for parents:\n\t", - join("\n\t", @tmp), "\n"; } @ret; } @@ -2457,6 +2495,20 @@ sub rewrite_root { $self->{-rewrite_root} = $rwr; } +sub rewrite_uuid { + my ($self) = @_; + return $self->{-rewrite_uuid} if exists $self->{-rewrite_uuid}; + my $k = "svn-remote.$self->{repo_id}.rewriteUUID"; + my $rwid = eval { command_oneline(qw/config --get/, $k) }; + if ($rwid) { + $rwid =~ s#/+$##; + if ($rwid !~ m#^[a-f0-9]{8}-(?:[a-f0-9]{4}-){3}[a-f0-9]{12}$#) { + die "$rwid is not a valid UUID (key: $k)\n"; + } + } + $self->{-rewrite_uuid} = $rwid; +} + sub metadata_url { my ($self) = @_; ($self->rewrite_root || $self->{url}) . @@ -2725,6 +2777,61 @@ sub do_fetch { $self->make_log_entry($rev, \@parents, $ed); } +sub mkemptydirs { + my ($self, $r) = @_; + + sub scan { + my ($r, $empty_dirs, $line) = @_; + if (defined $r && $line =~ /^r(\d+)$/) { + return 0 if $1 > $r; + } elsif ($line =~ /^ \+empty_dir: (.+)$/) { + $empty_dirs->{$1} = 1; + } elsif ($line =~ /^ \-empty_dir: (.+)$/) { + my @d = grep {m[^\Q$1\E(/|$)]} (keys %$empty_dirs); + delete @$empty_dirs{@d}; + } + 1; # continue + }; + + my %empty_dirs = (); + my $gz_file = "$self->{dir}/unhandled.log.gz"; + if (-f $gz_file) { + if (!$can_compress) { + warn "Compress::Zlib could not be found; ", + "empty directories in $gz_file will not be read\n"; + } else { + my $gz = Compress::Zlib::gzopen($gz_file, "rb") or + die "Unable to open $gz_file: $!\n"; + my $line; + while ($gz->gzreadline($line) > 0) { + scan($r, \%empty_dirs, $line) or last; + } + $gz->gzclose; + } + } + + if (open my $fh, '<', "$self->{dir}/unhandled.log") { + binmode $fh or croak "binmode: $!"; + while (<$fh>) { + scan($r, \%empty_dirs, $_) or last; + } + close $fh; + } + + my $strip = qr/\A\Q$self->{path}\E(?:\/|$)/; + foreach my $d (sort keys %empty_dirs) { + $d = uri_decode($d); + $d =~ s/$strip//; + next if -d $d; + if (-e _) { + warn "$d exists but is not a directory\n"; + } else { + print "creating empty directory: $d\n"; + mkpath([$d]); + } + } +} + sub get_untracked { my ($self, $ed) = @_; my @out; @@ -2878,14 +2985,326 @@ sub check_author { $author; } +sub find_extra_svk_parents { + my ($self, $ed, $tickets, $parents) = @_; + # aha! svk:merge property changed... + my @tickets = split "\n", $tickets; + my @known_parents; + for my $ticket ( @tickets ) { + my ($uuid, $path, $rev) = split /:/, $ticket; + if ( $uuid eq $self->ra_uuid ) { + my $url = $self->rewrite_root || $self->{url}; + my $repos_root = $url; + my $branch_from = $path; + $branch_from =~ s{^/}{}; + my $gs = $self->other_gs($repos_root."/".$branch_from, + $url, + $branch_from, + $rev, + $self->{ref_id}); + if ( my $commit = $gs->rev_map_get($rev, $uuid) ) { + # wahey! we found it, but it might be + # an old one (!) + push @known_parents, [ $rev, $commit ]; + } + } + } + # Ordering matters; highest-numbered commit merge tickets + # first, as they may account for later merge ticket additions + # or changes. + @known_parents = map {$_->[1]} sort {$b->[0] <=> $a->[0]} @known_parents; + for my $parent ( @known_parents ) { + my @cmd = ('rev-list', $parent, map { "^$_" } @$parents ); + my ($msg_fh, $ctx) = command_output_pipe(@cmd); + my $new; + while ( <$msg_fh> ) { + $new=1;last; + } + command_close_pipe($msg_fh, $ctx); + if ( $new ) { + print STDERR + "Found merge parent (svk:merge ticket): $parent\n"; + push @$parents, $parent; + } + } +} + +sub lookup_svn_merge { + my $uuid = shift; + my $url = shift; + my $merge = shift; + + my ($source, $revs) = split ":", $merge; + my $path = $source; + $path =~ s{^/}{}; + my $gs = Git::SVN->find_by_url($url.$source, $url, $path); + if ( !$gs ) { + warn "Couldn't find revmap for $url$source\n"; + return; + } + my @ranges = split ",", $revs; + my ($tip, $tip_commit); + my @merged_commit_ranges; + # find the tip + for my $range ( @ranges ) { + my ($bottom, $top) = split "-", $range; + $top ||= $bottom; + my $bottom_commit = $gs->find_rev_after( $bottom, 1, $top ); + my $top_commit = $gs->find_rev_before( $top, 1, $bottom ); + + unless ($top_commit and $bottom_commit) { + warn "W:unknown path/rev in svn:mergeinfo " + ."dirprop: $source:$range\n"; + next; + } + + push @merged_commit_ranges, + "$bottom_commit^..$top_commit"; + + if ( !defined $tip or $top > $tip ) { + $tip = $top; + $tip_commit = $top_commit; + } + } + return ($tip_commit, @merged_commit_ranges); +} + +sub _rev_list { + my ($msg_fh, $ctx) = command_output_pipe( + "rev-list", @_, + ); + my @rv; + while ( <$msg_fh> ) { + chomp; + push @rv, $_; + } + command_close_pipe($msg_fh, $ctx); + @rv; +} + +sub check_cherry_pick { + my $base = shift; + my $tip = shift; + my @ranges = @_; + my %commits = map { $_ => 1 } + _rev_list("--no-merges", $tip, "--not", $base); + for my $range ( @ranges ) { + delete @commits{_rev_list($range)}; + } + for my $commit (keys %commits) { + if (has_no_changes($commit)) { + delete $commits{$commit}; + } + } + return (keys %commits); +} + +sub has_no_changes { + my $commit = shift; + + my @revs = split / /, command_oneline( + qw(rev-list --parents -1 -m), $commit); + + # Commits with no parents, e.g. the start of a partial branch, + # have changes by definition. + return 1 if (@revs < 2); + + # Commits with multiple parents, e.g a merge, have no changes + # by definition. + return 0 if (@revs > 2); + + return (command_oneline("rev-parse", "$commit^{tree}") eq + command_oneline("rev-parse", "$commit~1^{tree}")); +} + +# The GIT_DIR environment variable is not always set until after the command +# line arguments are processed, so we can't memoize in a BEGIN block. +{ + my $memoized = 0; + + sub memoize_svn_mergeinfo_functions { + return if $memoized; + $memoized = 1; + + my $cache_path = "$ENV{GIT_DIR}/svn/.caches/"; + mkpath([$cache_path]) unless -d $cache_path; + + tie my %lookup_svn_merge_cache => 'Memoize::Storable', + "$cache_path/lookup_svn_merge.db", 'nstore'; + memoize 'lookup_svn_merge', + SCALAR_CACHE => 'FAULT', + LIST_CACHE => ['HASH' => \%lookup_svn_merge_cache], + ; + + tie my %check_cherry_pick_cache => 'Memoize::Storable', + "$cache_path/check_cherry_pick.db", 'nstore'; + memoize 'check_cherry_pick', + SCALAR_CACHE => 'FAULT', + LIST_CACHE => ['HASH' => \%check_cherry_pick_cache], + ; + + tie my %has_no_changes_cache => 'Memoize::Storable', + "$cache_path/has_no_changes.db", 'nstore'; + memoize 'has_no_changes', + SCALAR_CACHE => ['HASH' => \%has_no_changes_cache], + LIST_CACHE => 'FAULT', + ; + } +} + +sub parents_exclude { + my $parents = shift; + my @commits = @_; + return unless @commits; + + my @excluded; + my $excluded; + do { + my @cmd = ('rev-list', "-1", @commits, "--not", @$parents ); + $excluded = command_oneline(@cmd); + if ( $excluded ) { + my @new; + my $found; + for my $commit ( @commits ) { + if ( $commit eq $excluded ) { + push @excluded, $commit; + $found++; + last; + } + else { + push @new, $commit; + } + } + die "saw commit '$excluded' in rev-list output, " + ."but we didn't ask for that commit (wanted: @commits --not @$parents)" + unless $found; + @commits = @new; + } + } + while ($excluded and @commits); + + return @excluded; +} + + +# note: this function should only be called if the various dirprops +# have actually changed +sub find_extra_svn_parents { + my ($self, $ed, $mergeinfo, $parents) = @_; + # aha! svk:merge property changed... + + memoize_svn_mergeinfo_functions(); + + # We first search for merged tips which are not in our + # 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 @merge_tips; + my $url = $self->rewrite_root || $self->{url}; + my $uuid = $self->ra_uuid; + my %ranges; + for my $merge ( @merges ) { + my ($tip_commit, @ranges) = + lookup_svn_merge( $uuid, $url, $merge ); + unless (!$tip_commit or + grep { $_ eq $tip_commit } @$parents ) { + push @merge_tips, $tip_commit; + $ranges{$tip_commit} = \@ranges; + } else { + push @merge_tips, undef; + } + } + + my %excluded = map { $_ => 1 } + parents_exclude($parents, grep { defined } @merge_tips); + + # check merge tips for new parents + my @new_parents; + for my $merge_tip ( @merge_tips ) { + my $spec = shift @merges; + next unless $merge_tip and $excluded{$merge_tip}; + + my $ranges = $ranges{$merge_tip}; + + # check out 'new' tips + my $merge_base; + eval { + $merge_base = command_oneline( + "merge-base", + @$parents, $merge_tip, + ); + }; + if ($@) { + die "An error occurred during merge-base" + unless $@->isa("Git::Error::Command"); + + warn "W: Cannot find common ancestor between ". + "@$parents and $merge_tip. Ignoring merge info.\n"; + next; + } + + # double check that there are no missing non-merge commits + my (@incomplete) = check_cherry_pick( + $merge_base, $merge_tip, + @$ranges, + ); + + if ( @incomplete ) { + warn "W:svn cherry-pick ignored ($spec) - missing " + .@incomplete." commit(s) (eg $incomplete[0])\n"; + } else { + warn + "Found merge parent (svn:mergeinfo prop): ", + $merge_tip, "\n"; + push @new_parents, $merge_tip; + } + } + + # cater for merges which merge commits from multiple branches + if ( @new_parents > 1 ) { + for ( my $i = 0; $i <= $#new_parents; $i++ ) { + for ( my $j = 0; $j <= $#new_parents; $j++ ) { + next if $i == $j; + next unless $new_parents[$i]; + next unless $new_parents[$j]; + my $revs = command_oneline( + "rev-list", "-1", + "$new_parents[$i]..$new_parents[$j]", + ); + if ( !$revs ) { + undef($new_parents[$i]); + } + } + } + } + push @$parents, grep { defined } @new_parents; +} + sub make_log_entry { my ($self, $rev, $parents, $ed) = @_; 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); + } + if ( $props->{"svn:mergeinfo"} ) { + $self->find_extra_svn_parents + ($ed, + $props->{"svn:mergeinfo"}, + \@parents); + } + } + open my $un, '>>', "$self->{dir}/unhandled.log" or croak $!; print $un "r$rev\n" or croak $!; print $un $_, "\n" foreach @$untracked; - my %log_entry = ( parents => $parents || [], revision => $rev, + my %log_entry = ( parents => \@parents, revision => $rev, log => ''); my $headrev; @@ -2939,6 +3358,10 @@ sub make_log_entry { die "Can't have both 'useSvmProps' and 'rewriteRoot' ", "options set!\n"; } + if ($self->rewrite_uuid) { + die "Can't have both 'useSvmProps' and 'rewriteUUID' ", + "options set!\n"; + } my ($uuid, $r) = $headrev =~ m{^([a-f\d\-]{30,}):(\d+)$}i; # we don't want "SVM: initializing mirror for junk" ... return undef if $r == 0; @@ -2969,10 +3392,10 @@ sub make_log_entry { } else { my $url = $self->metadata_url; remove_username($url); - $log_entry{metadata} = "$url\@$rev " . - $self->ra->get_uuid; - $email ||= "$author\@" . $self->ra->get_uuid; - $commit_email ||= "$author\@" . $self->ra->get_uuid; + my $uuid = $self->rewrite_uuid || $self->ra->get_uuid; + $log_entry{metadata} = "$url\@$rev " . $uuid; + $email ||= "$author\@" . $uuid; + $commit_email ||= "$author\@" . $uuid; } $log_entry{name} = $name; $log_entry{email} = $email; @@ -3054,7 +3477,7 @@ sub rebuild { '--'); my $metadata_url = $self->metadata_url; remove_username($metadata_url); - my $svn_uuid = $self->ra_uuid; + my $svn_uuid = $self->rewrite_uuid || $self->ra_uuid; my $c; while (<$log>) { if ( m{^commit ($::sha1)$} ) { @@ -3411,6 +3834,12 @@ sub uri_encode { $f } +sub uri_decode { + my ($f) = @_; + $f =~ s#%([0-9a-fA-F]{2})#chr(hex($1))#eg; + $f +} + sub remove_username { $_[0] =~ s{^([^:]*://)[^@]+@}{$1}; } @@ -3692,11 +4121,11 @@ sub delete_entry { } print "\tD\t$gpath/\n" unless $::_q; command_close_pipe($ls, $ctx); - $self->{empty}->{$path} = 0 } else { $self->{gii}->remove($gpath); print "\tD\t$gpath\n" unless $::_q; } + $self->{empty}->{$path} = 0; undef; } @@ -4837,6 +5266,7 @@ sub match_globs { next if (length $g->{path}->{right} && ($self->check_path($p, $r) != $SVN::Node::dir)); + next unless $p =~ /$g->{path}->{regex}/; $exists->{$p} = Git::SVN->init($self->{url}, $p, undef, $g->{ref}->full_path($de), 1); } @@ -5029,17 +5459,20 @@ sub git_svn_log_cmd { # adapted from pager.c sub config_pager { - $pager ||= $ENV{GIT_PAGER} || $ENV{PAGER}; - if (!defined $pager) { - $pager = 'less'; - } elsif (length $pager == 0 || $pager eq 'cat') { + if (! -t *STDOUT) { + $ENV{GIT_PAGER_IN_USE} = 'false'; + $pager = undef; + return; + } + chomp($pager = command_oneline(qw(var GIT_PAGER))); + if ($pager eq 'cat') { $pager = undef; } $ENV{GIT_PAGER_IN_USE} = defined($pager); } sub run_pager { - return unless -t *STDOUT && defined $pager; + return unless defined $pager; pipe my ($rfd, $wfd) or return; defined(my $pid = fork) or ::fatal "Can't fork: $!"; if (!$pid) { @@ -5612,29 +6045,48 @@ use strict; use warnings; sub new { - my ($class, $glob) = @_; + my ($class, $glob, $pattern_ok) = @_; my $re = $glob; $re =~ s!/+$!!g; # no need for trailing slashes - $re =~ m!^([^*]*)(\*(?:/\*)*)(.*)$!; - my $temp = $re; - my ($left, $right) = ($1, $3); - $re = $2; - my $depth = $re =~ tr/*/*/; - if ($depth != $temp =~ tr/*/*/) { - die "Only one set of wildcard directories " . - "(e.g. '*' or '*/*/*') is supported: '$glob'\n"; + my (@left, @right, @patterns); + my $state = "left"; + my $die_msg = "Only one set of wildcard directories " . + "(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 =~ /[{}]/ && + $part !~ /^\{[^{}]+\}/) { + die "Invalid pattern in '$glob': $part\n"; + } + if ($part eq "*") { + die $die_msg if $state eq "right"; + $state = "pattern"; + push(@patterns, "[^/]*"); + } elsif ($pattern_ok && $part =~ /^\{(.*)\}$/) { + die $die_msg if $state eq "right"; + $state = "pattern"; + my $p = quotemeta($1); + $p =~ s/\\,/|/g; + push(@patterns, "(?:$p)"); + } else { + if ($state eq "left") { + push(@left, $part); + } else { + push(@right, $part); + $state = "right"; + } + } } + my $depth = @patterns; if ($depth == 0) { - die "One '*' is needed for glob: '$glob'\n"; - } - $re =~ s!\*!\[^/\]*!g; - $re = quotemeta($left) . "($re)" . quotemeta($right); - if (length $left && !($left =~ s!/+$!!g)) { - die "Missing trailing '/' on left side of: '$glob' ($left)\n"; - } - if (length $right && !($right =~ s!^/+!!g)) { - die "Missing leading '/' on right side of: '$glob' ($right)\n"; + die "One '*' is needed in glob: '$glob'\n"; } + my $left = join('/', @left); + my $right = join('/', @right); + $re = join('/', @patterns); + $re = join('\/', + grep(length, quotemeta($left), "($re)", quotemeta($right))); my $left_re = qr/^\/\Q$left\E(\/|$)/; bless { left => $left, right => $right, left_regex => $left_re, regex => qr/$re/, glob => $glob, depth => $depth }, $class; |