[1980] | 1 | # ------------------------------------------------------------------------------ |
---|
| 2 | # NAME |
---|
| 3 | # Fcm::ReposBranch |
---|
| 4 | # |
---|
| 5 | # DESCRIPTION |
---|
| 6 | # This class contains methods for gathering information for a repository |
---|
| 7 | # branch. It currently supports Subversion repository and local user |
---|
| 8 | # directory. |
---|
| 9 | # |
---|
| 10 | # COPYRIGHT |
---|
| 11 | # (C) Crown copyright Met Office. All rights reserved. |
---|
| 12 | # For further details please refer to the file COPYRIGHT.txt |
---|
| 13 | # which you should have received as part of this distribution. |
---|
| 14 | # ------------------------------------------------------------------------------ |
---|
| 15 | |
---|
| 16 | use warnings; |
---|
| 17 | use strict; |
---|
| 18 | |
---|
| 19 | package Fcm::ReposBranch; |
---|
| 20 | use base qw{Fcm::Base}; |
---|
| 21 | |
---|
| 22 | use Fcm::CfgLine; |
---|
| 23 | use Fcm::Keyword; |
---|
| 24 | use Fcm::Util qw{expand_tilde is_url run_command w_report}; |
---|
| 25 | use File::Basename qw{dirname}; |
---|
| 26 | use File::Find qw{find}; |
---|
| 27 | use File::Spec; |
---|
| 28 | |
---|
| 29 | # List of scalar property methods for this class |
---|
| 30 | my @scalar_properties = ( |
---|
| 31 | 'package', # package name of which this repository belongs |
---|
| 32 | 'repos', # repository branch root URL/path |
---|
| 33 | 'revision', # the revision of this branch |
---|
| 34 | 'tag', # "tag" name of this branch of the repository |
---|
| 35 | 'type', # repository type |
---|
| 36 | ); |
---|
| 37 | |
---|
| 38 | # List of hash property methods for this class |
---|
| 39 | my @hash_properties = ( |
---|
| 40 | 'dirs', # list of non-recursive directories in this branch |
---|
| 41 | 'expdirs', # list of recursive directories in this branch |
---|
| 42 | ); |
---|
| 43 | |
---|
| 44 | # ------------------------------------------------------------------------------ |
---|
| 45 | # SYNOPSIS |
---|
| 46 | # $obj = Fcm::ReposBranch->new (%args); |
---|
| 47 | # |
---|
| 48 | # DESCRIPTION |
---|
| 49 | # This method constructs a new instance of the Fcm::ReposBranch class. See |
---|
| 50 | # @scalar_properties above for allowed list of properties in the constructor. |
---|
| 51 | # (KEYS should be in uppercase.) |
---|
| 52 | # ------------------------------------------------------------------------------ |
---|
| 53 | |
---|
| 54 | sub new { |
---|
| 55 | my $this = shift; |
---|
| 56 | my %args = @_; |
---|
| 57 | my $class = ref $this || $this; |
---|
| 58 | |
---|
| 59 | my $self = Fcm::Base->new (%args); |
---|
| 60 | |
---|
| 61 | for (@scalar_properties) { |
---|
| 62 | $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; |
---|
| 63 | } |
---|
| 64 | |
---|
| 65 | $self->{$_} = {} for (@hash_properties); |
---|
| 66 | |
---|
| 67 | bless $self, $class; |
---|
| 68 | return $self; |
---|
| 69 | } |
---|
| 70 | |
---|
| 71 | # ------------------------------------------------------------------------------ |
---|
| 72 | # SYNOPSIS |
---|
| 73 | # $value = $obj->X; |
---|
| 74 | # $obj->X ($value); |
---|
| 75 | # |
---|
| 76 | # DESCRIPTION |
---|
| 77 | # Details of these properties are explained in @scalar_properties. |
---|
| 78 | # ------------------------------------------------------------------------------ |
---|
| 79 | |
---|
| 80 | for my $name (@scalar_properties) { |
---|
| 81 | no strict 'refs'; |
---|
| 82 | |
---|
| 83 | *$name = sub { |
---|
| 84 | my $self = shift; |
---|
| 85 | |
---|
| 86 | # Argument specified, set property to specified argument |
---|
| 87 | if (@_) { |
---|
| 88 | $self->{$name} = $_[0]; |
---|
| 89 | } |
---|
| 90 | |
---|
| 91 | return $self->{$name}; |
---|
| 92 | } |
---|
| 93 | } |
---|
| 94 | |
---|
| 95 | # ------------------------------------------------------------------------------ |
---|
| 96 | # SYNOPSIS |
---|
| 97 | # %hash = %{ $obj->X () }; |
---|
| 98 | # $obj->X (\%hash); |
---|
| 99 | # |
---|
| 100 | # $value = $obj->X ($index); |
---|
| 101 | # $obj->X ($index, $value); |
---|
| 102 | # |
---|
| 103 | # DESCRIPTION |
---|
| 104 | # Details of these properties are explained in @hash_properties. |
---|
| 105 | # |
---|
| 106 | # If no argument is set, this method returns a hash containing a list of |
---|
| 107 | # objects. If an argument is set and it is a reference to a hash, the objects |
---|
| 108 | # are replaced by the the specified hash. |
---|
| 109 | # |
---|
| 110 | # If a scalar argument is specified, this method returns a reference to an |
---|
| 111 | # object, if the indexed object exists or undef if the indexed object does |
---|
| 112 | # not exist. If a second argument is set, the $index element of the hash will |
---|
| 113 | # be set to the value of the argument. |
---|
| 114 | # ------------------------------------------------------------------------------ |
---|
| 115 | |
---|
| 116 | for my $name (@hash_properties) { |
---|
| 117 | no strict 'refs'; |
---|
| 118 | |
---|
| 119 | *$name = sub { |
---|
| 120 | my ($self, $arg1, $arg2) = @_; |
---|
| 121 | |
---|
| 122 | # Ensure property is defined as a reference to a hash |
---|
| 123 | $self->{$name} = {} if not defined ($self->{$name}); |
---|
| 124 | |
---|
| 125 | # Argument 1 can be a reference to a hash or a scalar index |
---|
| 126 | my ($index, %hash); |
---|
| 127 | |
---|
| 128 | if (defined $arg1) { |
---|
| 129 | if (ref ($arg1) eq 'HASH') { |
---|
| 130 | %hash = %$arg1; |
---|
| 131 | |
---|
| 132 | } else { |
---|
| 133 | $index = $arg1; |
---|
| 134 | } |
---|
| 135 | } |
---|
| 136 | |
---|
| 137 | if (defined $index) { |
---|
| 138 | # A scalar index is defined, set and/or return the value of an element |
---|
| 139 | $self->{$name}{$index} = $arg2 if defined $arg2; |
---|
| 140 | |
---|
| 141 | return ( |
---|
| 142 | exists $self->{$name}{$index} ? $self->{$name}{$index} : undef |
---|
| 143 | ); |
---|
| 144 | |
---|
| 145 | } else { |
---|
| 146 | # A scalar index is not defined, set and/or return the hash |
---|
| 147 | $self->{$name} = \%hash if defined $arg1; |
---|
| 148 | return $self->{$name}; |
---|
| 149 | } |
---|
| 150 | } |
---|
| 151 | } |
---|
| 152 | |
---|
| 153 | # ------------------------------------------------------------------------------ |
---|
| 154 | # SYNOPSIS |
---|
| 155 | # $rc = $obj->expand_revision; |
---|
| 156 | # |
---|
| 157 | # DESCRIPTION |
---|
| 158 | # This method expands the revision keywords of the current branch to a |
---|
| 159 | # revision number. It returns true on success. |
---|
| 160 | # ------------------------------------------------------------------------------ |
---|
| 161 | |
---|
| 162 | sub expand_revision { |
---|
| 163 | my $self = shift; |
---|
| 164 | |
---|
| 165 | my $rc = 1; |
---|
| 166 | if ($self->type eq 'svn') { |
---|
| 167 | # Expand revision keyword |
---|
| 168 | my $rev = (Fcm::Keyword::expand($self->repos(), $self->revision()))[1]; |
---|
| 169 | |
---|
| 170 | # Get last changed revision of the specified revision |
---|
| 171 | my $info_ref = $self->_svn_info($self->repos(), $rev); |
---|
| 172 | if (!defined($info_ref->{'Revision'})) { |
---|
| 173 | my $url = $self->repos() . ($rev ? '@' . $rev : q{}); |
---|
| 174 | w_report("ERROR: $url: not a valid URL\n"); |
---|
| 175 | return 0; |
---|
| 176 | } |
---|
| 177 | my $lc_rev = $info_ref->{'Last Changed Rev'}; |
---|
| 178 | $rev = $info_ref->{'Revision'}; |
---|
| 179 | |
---|
| 180 | # Print info if specified revision is not the last commit revision |
---|
| 181 | if (uc($self->revision()) ne 'HEAD' && $lc_rev != $rev) { |
---|
| 182 | my $message = $self->repos . '@' . $rev . ': last changed at [' . |
---|
| 183 | $lc_rev . '].'; |
---|
| 184 | if ($self->setting ('EXT_REVMATCH') and uc ($self->revision) ne 'HEAD') { |
---|
| 185 | w_report "ERROR: specified and last changed revisions differ:\n", |
---|
| 186 | ' ', $message, "\n"; |
---|
| 187 | $rc = 0; |
---|
| 188 | |
---|
| 189 | } else { |
---|
| 190 | print 'INFO: ', $message, "\n"; |
---|
| 191 | } |
---|
| 192 | } |
---|
| 193 | |
---|
| 194 | if ($self->verbose > 1 and uc ($self->revision) ne 'HEAD') { |
---|
| 195 | # See if there is a later change of the branch at the HEAD |
---|
| 196 | my $head_lc_rev = $self->_svn_info($self->repos())->{'Last Changed Rev'}; |
---|
| 197 | |
---|
| 198 | if (defined($head_lc_rev) && $head_lc_rev != $lc_rev) { |
---|
| 199 | # Ensure that this is the same branch by checking its history |
---|
| 200 | my @lines = &run_command ( |
---|
| 201 | [qw/svn log -q --incremental -r/, $lc_rev, $self->repos . '@HEAD'], |
---|
| 202 | METHOD => 'qx', TIME => $self->verbose > 2, |
---|
| 203 | ); |
---|
| 204 | |
---|
| 205 | print 'INFO: ', $self->repos, '@', $rev, |
---|
| 206 | ': newest commit at [', $head_lc_rev, '].', "\n" |
---|
| 207 | if @lines; |
---|
| 208 | } |
---|
| 209 | } |
---|
| 210 | |
---|
| 211 | $self->revision ($rev) if $rev ne $self->revision; |
---|
| 212 | |
---|
| 213 | } elsif ($self->type eq 'user') { |
---|
| 214 | 1; # Do nothing |
---|
| 215 | |
---|
| 216 | } else { |
---|
| 217 | w_report 'ERROR: ', $self->repos, ': repository type "', $self->type, |
---|
| 218 | '" not supported.'; |
---|
| 219 | $rc = 0; |
---|
| 220 | } |
---|
| 221 | |
---|
| 222 | return $rc; |
---|
| 223 | } |
---|
| 224 | |
---|
| 225 | # ------------------------------------------------------------------------------ |
---|
| 226 | # SYNOPSIS |
---|
| 227 | # $rc = $obj->expand_path; |
---|
| 228 | # |
---|
| 229 | # DESCRIPTION |
---|
| 230 | # This method expands the relative path names of sub-directories to full |
---|
| 231 | # path names. It returns true on success. |
---|
| 232 | # ------------------------------------------------------------------------------ |
---|
| 233 | |
---|
| 234 | sub expand_path { |
---|
| 235 | my $self = shift; |
---|
| 236 | |
---|
| 237 | my $rc = 1; |
---|
| 238 | if ($self->type eq 'svn') { |
---|
| 239 | # SVN repository |
---|
| 240 | # Do nothing unless there is a declared repository for this branch |
---|
| 241 | return unless $self->repos; |
---|
| 242 | |
---|
| 243 | # Remove trailing / |
---|
| 244 | my $repos = $self->repos; |
---|
| 245 | $self->repos ($repos) if $repos =~ s#/+$##; |
---|
| 246 | |
---|
| 247 | # Consider all declared (expandable) sub-directories |
---|
| 248 | for my $name (qw/dirs expdirs/) { |
---|
| 249 | for my $dir (keys %{ $self->$name }) { |
---|
| 250 | # Do nothing if declared sub-directory is quoted as a full URL |
---|
| 251 | next if &is_url ($self->$name ($dir)); |
---|
| 252 | |
---|
| 253 | # Expand sub-directory to full URL |
---|
| 254 | $self->$name ($dir, $self->repos . ( |
---|
| 255 | $self->$name ($dir) ? ('/' . $self->$name ($dir)) : '' |
---|
| 256 | )); |
---|
| 257 | } |
---|
| 258 | } |
---|
| 259 | # Note: "catfile" cannot be used in the above statement because it has |
---|
| 260 | # the tendency of removing a slash from double slashes. |
---|
| 261 | |
---|
| 262 | } elsif ($self->type eq 'user') { |
---|
| 263 | # Local user directories |
---|
| 264 | |
---|
| 265 | # Expand leading ~ for all declared (expandable) sub-directories |
---|
| 266 | for my $name (qw/dirs expdirs/) { |
---|
| 267 | for my $dir (keys %{ $self->$name }) { |
---|
| 268 | $self->$name ($dir, expand_tilde $self->$name ($dir)); |
---|
| 269 | } |
---|
| 270 | } |
---|
| 271 | |
---|
| 272 | # A top directory for the source is declared |
---|
| 273 | if ($self->repos) { |
---|
| 274 | # Expand leading ~ for the top directory |
---|
| 275 | $self->repos (expand_tilde $self->repos); |
---|
| 276 | |
---|
| 277 | # Get the root directory of the file system |
---|
| 278 | my $rootdir = File::Spec->rootdir (); |
---|
| 279 | |
---|
| 280 | # Expand top directory to absolute path, if necessary |
---|
| 281 | $self->repos (File::Spec->rel2abs ($self->repos)) |
---|
| 282 | if $self->repos !~ m/^$rootdir/; |
---|
| 283 | |
---|
| 284 | # Remove trailing / |
---|
| 285 | my $repos = $self->repos; |
---|
| 286 | $self->repos ($repos) if $repos =~ s#/+$##; |
---|
| 287 | |
---|
| 288 | # Consider all declared (expandable) sub-directories |
---|
| 289 | for my $name (qw/dirs expdirs/) { |
---|
| 290 | for my $dir (keys %{ $self->$name }) { |
---|
| 291 | # Do nothing if declared sub-directory is quoted as a full path |
---|
| 292 | next if $self->$name ($dir) =~ m#^$rootdir#; |
---|
| 293 | |
---|
| 294 | # Expand sub-directory to full path |
---|
| 295 | $self->$name ( |
---|
| 296 | $dir, $self->$name ($dir) |
---|
| 297 | ? File::Spec->catfile ($self->repos, $self->$name ($dir)) |
---|
| 298 | : $self->repos |
---|
| 299 | ); |
---|
| 300 | } |
---|
| 301 | } |
---|
| 302 | } |
---|
| 303 | |
---|
| 304 | } else { |
---|
| 305 | w_report 'ERROR: ', $self->repos, ': repository type "', $self->type, |
---|
| 306 | '" not supported.'; |
---|
| 307 | $rc = 0; |
---|
| 308 | } |
---|
| 309 | |
---|
| 310 | return $rc; |
---|
| 311 | } |
---|
| 312 | |
---|
| 313 | # ------------------------------------------------------------------------------ |
---|
| 314 | # SYNOPSIS |
---|
| 315 | # $rc = $obj->expand_all(); |
---|
| 316 | # |
---|
| 317 | # DESCRIPTION |
---|
| 318 | # This method searches the expandable source directories recursively for |
---|
| 319 | # source directories containing regular files. The namespaces and the locators |
---|
| 320 | # of these sub-directories are then added to the source directory hash table. |
---|
| 321 | # Returns true on success. |
---|
| 322 | # ------------------------------------------------------------------------------ |
---|
| 323 | |
---|
| 324 | sub expand_all { |
---|
| 325 | my ($self) = @_; |
---|
| 326 | my %finder_of = ( |
---|
| 327 | user => sub { |
---|
| 328 | my ($root_locator) = @_; |
---|
| 329 | my %ns_of; |
---|
| 330 | my $wanted = sub { |
---|
| 331 | my $base_name = $_; |
---|
| 332 | my $path = $File::Find::name; |
---|
| 333 | if (-f $path && -r $path && !-l $path) { |
---|
| 334 | my $dir_path = dirname($path); |
---|
| 335 | my $rel_dir_path = File::Spec->abs2rel($dir_path, $root_locator); |
---|
| 336 | if (!exists($ns_of{$dir_path})) { |
---|
| 337 | $ns_of{$dir_path} = [File::Spec->splitdir($rel_dir_path)]; |
---|
| 338 | } |
---|
| 339 | } |
---|
| 340 | }; |
---|
| 341 | find($wanted, $root_locator); |
---|
| 342 | return \%ns_of; |
---|
| 343 | }, |
---|
| 344 | svn => sub { |
---|
| 345 | my ($root_locator) = @_; |
---|
| 346 | my $runner = sub { |
---|
| 347 | map {chomp($_); $_} run_command( |
---|
| 348 | ['svn', @_, '-R', join('@', $root_locator, $self->revision())], |
---|
| 349 | METHOD => 'qx', TIME => $self->config()->verbose() > 2, |
---|
| 350 | ); |
---|
| 351 | }; |
---|
| 352 | # FIXME: check for symlink switched off due to "svn pg" being very slow |
---|
| 353 | #my %symlink_in |
---|
| 354 | # = map {($_ =~ qr{\A(.+)\s-\s(\*)\z}xms)} ($runner->(qw{pg svn:special})); |
---|
| 355 | #my @locators |
---|
| 356 | # = grep {$_ !~ qr{/\z}xms && !$symlink_in{$_}} ($runner->('ls')); |
---|
| 357 | my @locators = grep {$_ !~ qr{/\z}xms} ($runner->('ls')); |
---|
| 358 | my %ns_of; |
---|
| 359 | for my $locator (@locators) { |
---|
| 360 | my ($rel_dir_locator) = $locator =~ qr{\A(.*)/[^/]+\z}xms; # dirname |
---|
| 361 | $rel_dir_locator ||= q{}; |
---|
| 362 | my $dir_locator = join(q{/}, $root_locator, $rel_dir_locator); |
---|
| 363 | if (!exists($ns_of{$dir_locator})) { |
---|
| 364 | $ns_of{$dir_locator} = [split(q{/}, $rel_dir_locator)]; |
---|
| 365 | } |
---|
| 366 | } |
---|
| 367 | return \%ns_of; |
---|
| 368 | }, |
---|
| 369 | ); |
---|
| 370 | |
---|
| 371 | if (!defined($finder_of{$self->type()})) { |
---|
| 372 | w_report(sprintf( |
---|
| 373 | qq{ERROR: %s: resource type "%s" not supported}, |
---|
| 374 | $self->repos(), |
---|
| 375 | $self->type(), |
---|
| 376 | )); |
---|
| 377 | return; |
---|
| 378 | } |
---|
| 379 | while (my ($root_ns, $root_locator) = each(%{$self->expdirs()})) { |
---|
| 380 | my @root_ns_list = split(qr{$Fcm::Config::DELIMITER}xms, $root_ns); |
---|
| 381 | my $ns_hash_ref = $finder_of{$self->type()}->($root_locator); |
---|
| 382 | while (my ($dir_path, $ns_list_ref) = each(%{$ns_hash_ref})) { |
---|
| 383 | if (!grep {$_ =~ qr{\A\.}xms || $_ =~ qr{~\z}xms} @{$ns_list_ref}) { |
---|
| 384 | my $ns = join($Fcm::Config::DELIMITER, @root_ns_list, @{$ns_list_ref}); |
---|
| 385 | $self->dirs($ns, $dir_path); |
---|
| 386 | } |
---|
| 387 | } |
---|
| 388 | } |
---|
| 389 | return 1; |
---|
| 390 | } |
---|
| 391 | |
---|
| 392 | # ------------------------------------------------------------------------------ |
---|
| 393 | # SYNOPSIS |
---|
| 394 | # $n = $obj->add_base_dirs ($base); |
---|
| 395 | # |
---|
| 396 | # DESCRIPTION |
---|
| 397 | # Add a list of source directories to the current branch based on the set |
---|
| 398 | # provided by $base, which must be a reference to a Fcm::ReposBranch |
---|
| 399 | # instance. It returns the total number of used sub-directories in the |
---|
| 400 | # current repositories. |
---|
| 401 | # ------------------------------------------------------------------------------ |
---|
| 402 | |
---|
| 403 | sub add_base_dirs { |
---|
| 404 | my $self = shift; |
---|
| 405 | my $base = shift; |
---|
| 406 | |
---|
| 407 | my %base_dirs = %{ $base->dirs }; |
---|
| 408 | |
---|
| 409 | for my $key (keys %base_dirs) { |
---|
| 410 | # Remove repository root from base directories |
---|
| 411 | if ($base_dirs{$key} eq $base->repos) { |
---|
| 412 | $base_dirs{$key} = ''; |
---|
| 413 | |
---|
| 414 | } else { |
---|
| 415 | $base_dirs{$key} = substr $base_dirs{$key}, length ($base->repos) + 1; |
---|
| 416 | } |
---|
| 417 | |
---|
| 418 | # Append base directories to current repository root |
---|
| 419 | $self->dirs ($key, $base_dirs{$key}); |
---|
| 420 | } |
---|
| 421 | |
---|
| 422 | # Expand relative path names of sub-directories |
---|
| 423 | $self->expand_path; |
---|
| 424 | |
---|
| 425 | return scalar keys %{ $self->dirs }; |
---|
| 426 | } |
---|
| 427 | |
---|
| 428 | # ------------------------------------------------------------------------------ |
---|
| 429 | # SYNOPSIS |
---|
| 430 | # @cfglines = $obj->to_cfglines (); |
---|
| 431 | # |
---|
| 432 | # DESCRIPTION |
---|
| 433 | # This method returns a list of configuration lines for the current branch. |
---|
| 434 | # ------------------------------------------------------------------------------ |
---|
| 435 | |
---|
| 436 | sub to_cfglines { |
---|
| 437 | my ($self) = @_; |
---|
| 438 | my @return = (); |
---|
| 439 | |
---|
| 440 | my $suffix = $self->package . $Fcm::Config::DELIMITER . $self->tag; |
---|
| 441 | push @return, Fcm::CfgLine->new ( |
---|
| 442 | label => $self->cfglabel ('REPOS') . $Fcm::Config::DELIMITER . $suffix, |
---|
| 443 | value => $self->repos, |
---|
| 444 | ) if $self->repos; |
---|
| 445 | |
---|
| 446 | push @return, Fcm::CfgLine->new ( |
---|
| 447 | label => $self->cfglabel ('REVISION') . $Fcm::Config::DELIMITER . $suffix, |
---|
| 448 | value => $self->revision, |
---|
| 449 | ) if $self->revision; |
---|
| 450 | |
---|
| 451 | for my $key (sort keys %{ $self->dirs }) { |
---|
| 452 | my $value = $self->dirs ($key); |
---|
| 453 | |
---|
| 454 | # Use relative path where possible |
---|
| 455 | if ($self->repos) { |
---|
| 456 | if ($value eq $self->repos) { |
---|
| 457 | $value = ''; |
---|
| 458 | |
---|
| 459 | } elsif (index ($value, $self->repos) == 0) { |
---|
| 460 | $value = substr ($value, length ($self->repos) + 1); |
---|
| 461 | } |
---|
| 462 | } |
---|
| 463 | |
---|
| 464 | # Use top package name where possible |
---|
| 465 | my $dsuffix = $key . $Fcm::Config::DELIMITER . $self->tag; |
---|
| 466 | $dsuffix = $suffix if $value ne $self->dirs ($key) and $key eq join ( |
---|
| 467 | $Fcm::Config::DELIMITER, $self->package, File::Spec->splitdir ($value) |
---|
| 468 | ); |
---|
| 469 | |
---|
| 470 | push @return, Fcm::CfgLine->new ( |
---|
| 471 | label => $self->cfglabel ('DIRS') . $Fcm::Config::DELIMITER . $dsuffix, |
---|
| 472 | value => $value, |
---|
| 473 | ); |
---|
| 474 | } |
---|
| 475 | |
---|
| 476 | push @return, Fcm::CfgLine->new (); |
---|
| 477 | |
---|
| 478 | return @return; |
---|
| 479 | } |
---|
| 480 | |
---|
| 481 | # ------------------------------------------------------------------------------ |
---|
| 482 | # SYNOPSIS |
---|
| 483 | # my $hash_ref = $self->_svn_info($url[, $rev]); |
---|
| 484 | # |
---|
| 485 | # DESCRIPTION |
---|
| 486 | # Executes "svn info" and returns each field in a hash. |
---|
| 487 | # ------------------------------------------------------------------------------ |
---|
| 488 | sub _svn_info { |
---|
| 489 | my ($self, $url, $rev) = @_; |
---|
| 490 | return { |
---|
| 491 | map { |
---|
| 492 | chomp(); |
---|
| 493 | my ($key, $value) = split(qr{\s*:\s*}xms, $_, 2); |
---|
| 494 | $key ? ($key, $value) : (); |
---|
| 495 | } run_command( |
---|
| 496 | [qw{svn info}, ($rev ? ('-r', $rev, join('@', $url, $rev)) : $url)], |
---|
| 497 | DEVNULL => 1, METHOD => 'qx', TIME => $self->verbose() > 2, |
---|
| 498 | ) |
---|
| 499 | }; |
---|
| 500 | } |
---|
| 501 | |
---|
| 502 | # ------------------------------------------------------------------------------ |
---|
| 503 | |
---|
| 504 | 1; |
---|
| 505 | |
---|
| 506 | __END__ |
---|