summaryrefslogtreecommitdiff
path: root/perl
diff options
context:
space:
mode:
Diffstat (limited to 'perl')
-rw-r--r--perl/Git.pm72
-rw-r--r--perl/Git/SVN.pm87
-rw-r--r--perl/Git/SVN/Editor.pm4
-rw-r--r--perl/Git/SVN/GlobSpec.pm18
-rw-r--r--perl/Git/SVN/Ra.pm8
5 files changed, 168 insertions, 21 deletions
diff --git a/perl/Git.pm b/perl/Git.pm
index 9026a7bb98..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
@@ -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 )
diff --git a/perl/Git/SVN.pm b/perl/Git/SVN.pm
index 152fb7e927..d94d01cfdc 100644
--- a/perl/Git/SVN.pm
+++ b/perl/Git/SVN.pm
@@ -97,7 +97,8 @@ sub resolve_local_globs {
"existing: $existing\n",
" globbed: $refname\n";
}
- my $u = (::cmt_metadata("$refname"))[0];
+ my $u = (::cmt_metadata("$refname"))[0] or die
+ "$refname: no associated commit metadata\n";
$u =~ s!^\Q$url\E(/|$)!! or die
"$refname: '$url' not found in '$u'\n";
if ($pathname ne $u) {
@@ -1211,20 +1212,87 @@ sub do_fetch {
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()) {
@@ -1235,7 +1303,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;
}
@@ -1244,13 +1312,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);
diff --git a/perl/Git/SVN/Editor.pm b/perl/Git/SVN/Editor.pm
index c50176eec9..4c4199afec 100644
--- a/perl/Git/SVN/Editor.pm
+++ b/perl/Git/SVN/Editor.pm
@@ -41,6 +41,7 @@ sub new {
"$self->{svn_path}/" : '';
$self->{config} = $opts->{config};
$self->{mergeinfo} = $opts->{mergeinfo};
+ $self->{pathnameencoding} = Git::config('svn.pathnameencoding');
return $self;
}
@@ -143,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 {
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/Ra.pm b/perl/Git/SVN/Ra.pm
index 4a499fcb38..e764696801 100644
--- a/perl/Git/SVN/Ra.pm
+++ b/perl/Git/SVN/Ra.pm
@@ -81,7 +81,6 @@ 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 $dont_store_passwords = 1;
my $conf_t = $config->{'config'};
no warnings 'once';
@@ -93,9 +92,14 @@ sub prepare_config_once {
$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,
- bless (\$dont_store_passwords, "_p_void"));
+ $val);
}
if (SVN::_Core::svn_config_get_bool($conf_t,
$SVN::_Core::SVN_CONFIG_SECTION_AUTH,
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 10:47:32 +0000