[10] | 1 | #!/usr/bin/perl |
---|
| 2 | # ------------------------------------------------------------------------------ |
---|
| 3 | # NAME |
---|
| 4 | # Fcm::Util |
---|
| 5 | # |
---|
| 6 | # DESCRIPTION |
---|
| 7 | # This is a package of misc utilities used by the FCM command. |
---|
| 8 | # |
---|
| 9 | # COPYRIGHT |
---|
| 10 | # (C) Crown copyright Met Office. All rights reserved. |
---|
| 11 | # For further details please refer to the file COPYRIGHT.txt |
---|
| 12 | # which you should have received as part of this distribution. |
---|
| 13 | # ------------------------------------------------------------------------------ |
---|
| 14 | |
---|
| 15 | package Fcm::Util; |
---|
| 16 | |
---|
| 17 | # Standard pragma |
---|
| 18 | use warnings; |
---|
| 19 | use strict; |
---|
| 20 | |
---|
| 21 | # Exports |
---|
| 22 | our (@ISA, @EXPORT, @EXPORT_OK); |
---|
| 23 | |
---|
| 24 | sub expand_rev_keyword; |
---|
| 25 | sub expand_tilde; |
---|
| 26 | sub expand_url_keyword; |
---|
| 27 | sub e_report; |
---|
| 28 | sub find_srcdir; |
---|
| 29 | sub find_file_in_path; |
---|
| 30 | sub get_browser_url; |
---|
| 31 | sub get_command_string; |
---|
| 32 | sub get_rev_of_wc; |
---|
| 33 | sub get_rev_keyword; |
---|
| 34 | sub get_url_of_wc; |
---|
| 35 | sub get_wct; |
---|
| 36 | sub is_url; |
---|
| 37 | sub is_wc; |
---|
| 38 | sub print_command; |
---|
| 39 | sub run_command; |
---|
| 40 | sub svn_date; |
---|
| 41 | sub touch_file; |
---|
| 42 | sub w_report; |
---|
| 43 | |
---|
| 44 | require Exporter; |
---|
| 45 | @ISA = qw(Exporter); |
---|
| 46 | @EXPORT = qw( |
---|
| 47 | expand_rev_keyword |
---|
| 48 | expand_tilde |
---|
| 49 | expand_url_keyword |
---|
| 50 | e_report |
---|
| 51 | find_srcdir |
---|
| 52 | find_file_in_path |
---|
| 53 | get_browser_url |
---|
| 54 | get_command_string |
---|
| 55 | get_rev_of_wc |
---|
| 56 | get_rev_keyword |
---|
| 57 | get_url_of_wc |
---|
| 58 | get_wct |
---|
| 59 | is_url |
---|
| 60 | is_wc |
---|
| 61 | print_command |
---|
| 62 | run_command |
---|
| 63 | svn_date |
---|
| 64 | touch_file |
---|
| 65 | w_report |
---|
| 66 | ); |
---|
| 67 | |
---|
| 68 | # Standard modules |
---|
| 69 | use Carp; |
---|
| 70 | use Cwd; |
---|
| 71 | use File::Basename; |
---|
| 72 | use File::Find; |
---|
| 73 | use File::Path; |
---|
| 74 | use File::Spec; |
---|
| 75 | use POSIX qw/strftime/; |
---|
| 76 | |
---|
| 77 | # FCM component modules |
---|
| 78 | use Fcm::Timer; |
---|
| 79 | |
---|
| 80 | # ------------------------------------------------------------------------------ |
---|
| 81 | |
---|
| 82 | # Module level variables |
---|
| 83 | my %svn_info = (); # "svn info" log, (key1 = path, |
---|
| 84 | # key2 = URL, Revision, Last Changed Rev) |
---|
| 85 | |
---|
| 86 | # ------------------------------------------------------------------------------ |
---|
| 87 | # SYNOPSIS |
---|
| 88 | # %srcdir = &Fcm::Util::find_srcdir ($topdir, $toppck, $join); |
---|
| 89 | # |
---|
| 90 | # DESCRIPTION |
---|
| 91 | # Search $topdir for sub-directories containing regular files. Returns a hash |
---|
| 92 | # with each key/value pair assigned to a unique name of the source directory |
---|
| 93 | # and the location of the source directory. If $toppck is set the name of |
---|
| 94 | # each source directory will be prefixed with this package name, and the |
---|
| 95 | # search may include the $topdir in the result. If $join is set, the name of |
---|
| 96 | # the sub-package will use $join as the delimiter of packages. Otherwise, the |
---|
| 97 | # default double underscore '__' will be used. Please note that all |
---|
| 98 | # directories beginning with a ".", i.e. hidden directories, are ignored. |
---|
| 99 | # ------------------------------------------------------------------------------ |
---|
| 100 | |
---|
| 101 | sub find_srcdir { |
---|
| 102 | (my $topdir, my $toppck, my $join) = @_; |
---|
| 103 | $join = defined ($join) ? $join : '__'; |
---|
| 104 | |
---|
| 105 | my @dirs = (); |
---|
| 106 | |
---|
| 107 | # Locate all source directories containing regular files |
---|
| 108 | if (-d $topdir) { |
---|
| 109 | find ( |
---|
| 110 | sub { |
---|
| 111 | my $dir = $File::Find::name; |
---|
| 112 | return 0 if $dir eq $topdir and not $toppck; |
---|
| 113 | |
---|
| 114 | if (-d $dir) { |
---|
| 115 | # Ignore sub-directories with names beginning with . |
---|
| 116 | if ($dir ne $topdir) { |
---|
| 117 | my $subdir = substr ($dir, length ($topdir) + 1); |
---|
| 118 | return 0 if grep {m/^\./} File::Spec->splitdir ($subdir); |
---|
| 119 | } |
---|
| 120 | |
---|
| 121 | # Read contents of directory |
---|
| 122 | opendir DIR, $dir; |
---|
| 123 | my @files = readdir 'DIR'; |
---|
| 124 | closedir DIR; |
---|
| 125 | |
---|
| 126 | # Check if the directory contains one or more source file |
---|
| 127 | my $contain_src; |
---|
| 128 | for my $file (@files) { |
---|
| 129 | next if $file =~ /^\./; # ignore hidden file |
---|
| 130 | |
---|
| 131 | if (-f File::Spec->catfile ($dir, $file)) { |
---|
| 132 | $contain_src = 1; |
---|
| 133 | last; |
---|
| 134 | } |
---|
| 135 | } |
---|
| 136 | |
---|
| 137 | push @dirs, $dir if $contain_src; |
---|
| 138 | return 1; |
---|
| 139 | |
---|
| 140 | } else { |
---|
| 141 | return 0; |
---|
| 142 | } |
---|
| 143 | }, |
---|
| 144 | |
---|
| 145 | $topdir, |
---|
| 146 | ); |
---|
| 147 | } |
---|
| 148 | |
---|
| 149 | # String length of src directory name |
---|
| 150 | my $topdir_len = length $topdir; |
---|
| 151 | |
---|
| 152 | # Assign new source directories to current build |
---|
| 153 | my @pck = $toppck ? split (/$join/, $toppck) : (); |
---|
| 154 | my %srcdir = (); |
---|
| 155 | for my $dir (@dirs) { |
---|
| 156 | my $name = ($dir eq $topdir) ? '' : substr $dir, $topdir_len + 1; |
---|
| 157 | my @path = File::Spec->splitdir ($name); |
---|
| 158 | my $key = join $join, (@pck, @path); |
---|
| 159 | |
---|
| 160 | $srcdir{$key} = $dir; |
---|
| 161 | } |
---|
| 162 | |
---|
| 163 | return %srcdir; |
---|
| 164 | } |
---|
| 165 | |
---|
| 166 | # ------------------------------------------------------------------------------ |
---|
| 167 | # SYNOPSIS |
---|
| 168 | # %srcdir = &Fcm::Util::find_file_in_path ($file, \@path); |
---|
| 169 | # |
---|
| 170 | # DESCRIPTION |
---|
| 171 | # Search $file in @path. Returns the full path of the $file if it is found |
---|
| 172 | # in @path. Returns "undef" if $file is not found in @path. |
---|
| 173 | # ------------------------------------------------------------------------------ |
---|
| 174 | |
---|
| 175 | sub find_file_in_path { |
---|
| 176 | my ($file, $path) = @_; |
---|
| 177 | |
---|
| 178 | for my $dir (@$path) { |
---|
| 179 | my $full_file = File::Spec->catfile ($dir, $file); |
---|
| 180 | return $full_file if -e $full_file; |
---|
| 181 | } |
---|
| 182 | |
---|
| 183 | return undef; |
---|
| 184 | } |
---|
| 185 | |
---|
| 186 | # ------------------------------------------------------------------------------ |
---|
| 187 | # SYNOPSIS |
---|
| 188 | # $expanded_path = &Fcm::Util::expand_tilde ($path); |
---|
| 189 | # |
---|
| 190 | # DESCRIPTION |
---|
| 191 | # Returns an expanded path if $path is a path that begins with a tilde (~). |
---|
| 192 | # ------------------------------------------------------------------------------ |
---|
| 193 | |
---|
| 194 | sub expand_tilde { |
---|
| 195 | my $file = $_[0]; |
---|
| 196 | |
---|
| 197 | $file =~ s#^~([^/]*)#$1 ? (getpwnam $1)[7] : ($ENV{HOME} || $ENV{LOGDIR})#ex; |
---|
| 198 | |
---|
| 199 | return $file; |
---|
| 200 | } |
---|
| 201 | |
---|
| 202 | # ------------------------------------------------------------------------------ |
---|
| 203 | # SYNOPSIS |
---|
| 204 | # $rc = &Fcm::Util::touch_file ($file); |
---|
| 205 | # |
---|
| 206 | # DESCRIPTION |
---|
| 207 | # Touch $file if it exists. Create $file if it does not exist. Return 1 for |
---|
| 208 | # success or 0 otherwise. |
---|
| 209 | # ------------------------------------------------------------------------------ |
---|
| 210 | |
---|
| 211 | sub touch_file { |
---|
| 212 | my $file = $_[0]; |
---|
| 213 | my $rc = 1; |
---|
| 214 | |
---|
| 215 | if (-e $file) { |
---|
| 216 | my $now = time; |
---|
| 217 | $rc = utime $now, $now, $file; |
---|
| 218 | |
---|
| 219 | } else { |
---|
| 220 | mkpath dirname ($file) unless -d dirname ($file); |
---|
| 221 | |
---|
| 222 | $rc = open FILE, '>', $file; |
---|
| 223 | $rc = close FILE if $rc; |
---|
| 224 | } |
---|
| 225 | |
---|
| 226 | return $rc; |
---|
| 227 | } |
---|
| 228 | |
---|
| 229 | # ------------------------------------------------------------------------------ |
---|
| 230 | # SYNOPSIS |
---|
| 231 | # $new_url = &Fcm::Util::expand_url_keyword (URL => $url[, CFG => $cfg]); |
---|
| 232 | # |
---|
| 233 | # DESCRIPTION |
---|
| 234 | # Expand URL if its begins with a pre-defined pattern followed by a keyword |
---|
| 235 | # that can be found in the setting of CFG. If URL is a genuine URL, the |
---|
| 236 | # function also attempts to expand any . or .. in the path. If CFG is not |
---|
| 237 | # set, it defaults to &main::cfg. |
---|
| 238 | # ------------------------------------------------------------------------------ |
---|
| 239 | |
---|
| 240 | sub expand_url_keyword { |
---|
| 241 | my %args = @_; |
---|
| 242 | my $url = $args{URL}; |
---|
| 243 | my $cfg = exists $args{CFG} ? $args{CFG} : &main::cfg; |
---|
| 244 | |
---|
| 245 | # URL keyword prefix and pattern |
---|
| 246 | my $prefix = $cfg->setting (qw/MISC EXPURL_PREFIX/); |
---|
| 247 | my $pattern = '^' . $prefix . '(\w+)'; |
---|
| 248 | |
---|
| 249 | # URL matches pattern? |
---|
| 250 | if ($url =~ /$pattern/) { |
---|
| 251 | my $keyword = $1; |
---|
| 252 | |
---|
| 253 | # Determine whether keyword is registered. If so, expand keyword |
---|
| 254 | my $keyval = $cfg->setting ('REPOS', uc ($keyword)); |
---|
| 255 | $url =~ s/$pattern/$keyval/ if $keyval; |
---|
| 256 | } |
---|
| 257 | |
---|
| 258 | # Expand . and .. |
---|
| 259 | if (&is_url ($url)) { |
---|
| 260 | while ($url =~ s#/\.(?:/|$)#/#g) {next} |
---|
| 261 | while ($url =~ s#/[^/]+/\.\.(?:/|$)#/#g) {next} |
---|
| 262 | } |
---|
| 263 | |
---|
| 264 | return $url; |
---|
| 265 | } |
---|
| 266 | |
---|
| 267 | # ------------------------------------------------------------------------------ |
---|
| 268 | # SYNOPSIS |
---|
| 269 | # $new_rev = &Fcm::Util::expand_rev_keyword ( |
---|
| 270 | # REV => $rev, |
---|
| 271 | # URL => $url, |
---|
| 272 | # [HEAD => $flag,] |
---|
| 273 | # [CFG => $cfg,] |
---|
| 274 | # ); |
---|
| 275 | # |
---|
| 276 | # DESCRIPTION |
---|
| 277 | # Expand REV if URL is a known URL in CFG setting and REV matches a revision |
---|
| 278 | # keyword of this URL, or if REV is "HEAD". SVN revision numbers, date and |
---|
| 279 | # other keywords are ignored. HEAD should only be specified if REV has the |
---|
| 280 | # value "HEAD". If HEAD is specified and is true, the return value of the |
---|
| 281 | # function will be the operative revision number of the HEAD revision. |
---|
| 282 | # Otherwise, the last commit revision will be returned. If CFG is not set, |
---|
| 283 | # it defaults to &main::cfg. |
---|
| 284 | # ------------------------------------------------------------------------------ |
---|
| 285 | |
---|
| 286 | sub expand_rev_keyword { |
---|
| 287 | my %args = @_; |
---|
| 288 | my $rev = $args{REV}; |
---|
| 289 | my $url = $args{URL}; |
---|
| 290 | my $head = exists $args{HEAD} ? $args{HEAD} : undef; |
---|
| 291 | my $cfg = exists $args{CFG } ? $args{CFG } : &main::cfg; |
---|
| 292 | |
---|
| 293 | if (uc ($rev) eq 'HEAD') { |
---|
| 294 | # Expand HEAD revision |
---|
| 295 | &_invoke_svn_info (PATH => $url, CFG => $cfg) unless exists $svn_info{$url}; |
---|
| 296 | my $expanded_rev = $head |
---|
| 297 | ? $svn_info{$url}{Revision} |
---|
| 298 | : $svn_info{$url}{'Last Changed Rev'}; |
---|
| 299 | |
---|
| 300 | &w_report ($url, ': cannot determine HEAD revision.') |
---|
| 301 | if $cfg->verbose > 1 and not $expanded_rev; |
---|
| 302 | |
---|
| 303 | $rev = $expanded_rev if $expanded_rev; |
---|
| 304 | |
---|
| 305 | } elsif ($rev !~ /^(?:\d+|BASE|COMMITTED|PREV|\{.+\})$/i) { |
---|
| 306 | # Expand revision keyword, if required |
---|
| 307 | |
---|
| 308 | # Get configuration settings |
---|
| 309 | my %keywords = %{ $cfg->setting (qw/REVISION/) }; |
---|
| 310 | my $separator = $cfg->setting (qw/MISC DIR_SEPARATOR/); |
---|
| 311 | |
---|
| 312 | my $name = ''; |
---|
| 313 | |
---|
| 314 | # Find out whether URL matches a registered repository |
---|
| 315 | for my $keyword (keys %keywords) { |
---|
| 316 | my $repos = $cfg->setting ('REPOS', uc ($keyword)); |
---|
| 317 | next unless $repos; |
---|
| 318 | |
---|
| 319 | if ($url =~ m#^$repos(?:$separator|$)#) { |
---|
| 320 | $name = $keyword; |
---|
| 321 | last; |
---|
| 322 | } |
---|
| 323 | } |
---|
| 324 | |
---|
| 325 | # If revision keyword exists for the registered repository, expand it |
---|
| 326 | if ($name and exists $keywords{$name}{uc ($rev)}) { |
---|
| 327 | $rev = $keywords{$name}{uc ($rev)}; |
---|
| 328 | |
---|
| 329 | } else { |
---|
| 330 | &e_report ( |
---|
| 331 | $rev, ': revision keyword not found for ', $url, |
---|
| 332 | ' in FCM configuration file, abort.', |
---|
| 333 | ); |
---|
| 334 | } |
---|
| 335 | } |
---|
| 336 | |
---|
| 337 | return $rev; |
---|
| 338 | } |
---|
| 339 | |
---|
| 340 | # ------------------------------------------------------------------------------ |
---|
| 341 | # SYNOPSIS |
---|
| 342 | # $keyword = Fcm::Util::get_rev_keyword ( |
---|
| 343 | # REV => $rev, |
---|
| 344 | # URL => $url, |
---|
| 345 | # [CFG => $cfg,] |
---|
| 346 | # ); |
---|
| 347 | # |
---|
| 348 | # DESCRIPTION |
---|
| 349 | # Returns a revision keyword if URL is a known URL in CFG setting and REV is |
---|
| 350 | # a revision number that matches a revision keyword of this URL. Otherwise, |
---|
| 351 | # it returns REV unchanged. If CFG is not set, it defaults to &main::cfg. |
---|
| 352 | # ------------------------------------------------------------------------------ |
---|
| 353 | |
---|
| 354 | sub get_rev_keyword { |
---|
| 355 | my %args = @_; |
---|
| 356 | my $rev = $args{REV}; |
---|
| 357 | my $url = $args{URL}; |
---|
| 358 | my $cfg = exists $args{CFG} ? $args{CFG} : &main::cfg; |
---|
| 359 | |
---|
| 360 | if ($rev =~ /^\d+$/) { |
---|
| 361 | # Get revision keyword, if REV is a revision number |
---|
| 362 | |
---|
| 363 | # Get configuration settings |
---|
| 364 | my %keywords = %{ $cfg->setting (qw/REVISION/) }; |
---|
| 365 | my $separator = $cfg->setting (qw/MISC DIR_SEPARATOR/); |
---|
| 366 | |
---|
| 367 | my $name = ''; |
---|
| 368 | |
---|
| 369 | # Find out whether URL matches a registered repository |
---|
| 370 | for my $keyword (keys %keywords) { |
---|
| 371 | my $repos = $cfg->setting ('REPOS', uc ($keyword)); |
---|
| 372 | next unless $repos; |
---|
| 373 | |
---|
| 374 | if ($url =~ m#^$repos(?:$separator|$)#) { |
---|
| 375 | $name = $keyword; |
---|
| 376 | last; |
---|
| 377 | } |
---|
| 378 | } |
---|
| 379 | |
---|
| 380 | # If revision keyword for REV exists for the registered repository, get it |
---|
| 381 | if ($name and exists $keywords{$name} and ref $keywords{$name} eq 'HASH') { |
---|
| 382 | for my $key (keys %{ $keywords{$name} }) { |
---|
| 383 | if ($rev eq $keywords{$name}{$key}) { |
---|
| 384 | $rev = $key; |
---|
| 385 | last; |
---|
| 386 | } |
---|
| 387 | } |
---|
| 388 | } |
---|
| 389 | } |
---|
| 390 | |
---|
| 391 | return $rev; |
---|
| 392 | } |
---|
| 393 | |
---|
| 394 | # ------------------------------------------------------------------------------ |
---|
| 395 | # SYNOPSIS |
---|
| 396 | # $browser_url = Fcm::Util::get_browser_url ( |
---|
| 397 | # URL => $url, |
---|
| 398 | # [CFG => $cfg,] |
---|
| 399 | # ); |
---|
| 400 | # |
---|
| 401 | # DESCRIPTION |
---|
| 402 | # Returns a web address for browsing URL from Trac if URL is a known URL in |
---|
| 403 | # CFG setting, and that it is a matching web address. Otherwise, it returns |
---|
| 404 | # "undef". If CFG is not set, it defaults to &main::cfg. |
---|
| 405 | # ------------------------------------------------------------------------------ |
---|
| 406 | |
---|
| 407 | sub get_browser_url { |
---|
| 408 | my %args = @_; |
---|
| 409 | my $url = $args{URL}; |
---|
| 410 | my $cfg = exists $args{CFG} ? $args{CFG} : &main::cfg; |
---|
| 411 | my $browser_url = undef; |
---|
| 412 | |
---|
| 413 | # Get configuration settings |
---|
| 414 | my %keywords = %{ $cfg->setting (qw/TRAC/) }; |
---|
| 415 | my $separator = $cfg->setting (qw/MISC DIR_SEPARATOR/); |
---|
| 416 | |
---|
| 417 | my $name = ''; |
---|
| 418 | my $trail = ''; |
---|
| 419 | |
---|
| 420 | # Find out whether URL matches a registered repository |
---|
| 421 | for my $keyword (keys %keywords) { |
---|
| 422 | my $repos = $cfg->setting ('REPOS', uc ($keyword)); |
---|
| 423 | next unless $repos; |
---|
| 424 | |
---|
| 425 | if ($url =~ m#^$repos(?:$separator(.*$)|$)#) { |
---|
| 426 | $name = $keyword; |
---|
| 427 | $trail = $1 if $1; |
---|
| 428 | last; |
---|
| 429 | } |
---|
| 430 | } |
---|
| 431 | |
---|
| 432 | # If TRAC web address exists for the registered repository, get it |
---|
| 433 | if ($name and exists $keywords{$name}) { |
---|
| 434 | $browser_url = $keywords{$name}; |
---|
| 435 | $browser_url .= $separator . $trail if $trail; |
---|
| 436 | } |
---|
| 437 | |
---|
| 438 | return $browser_url; |
---|
| 439 | } |
---|
| 440 | |
---|
| 441 | # ------------------------------------------------------------------------------ |
---|
| 442 | # SYNOPSIS |
---|
| 443 | # $flag = &is_wc ([$path]); |
---|
| 444 | # |
---|
| 445 | # DESCRIPTION |
---|
| 446 | # Returns true if current working directory (or $path) is a Subversion |
---|
| 447 | # working copy. |
---|
| 448 | # ------------------------------------------------------------------------------ |
---|
| 449 | |
---|
| 450 | sub is_wc { |
---|
| 451 | my $path = @_ ? $_[0] : cwd (); |
---|
| 452 | |
---|
| 453 | if (-d $path) { |
---|
| 454 | return (-e File::Spec->catfile ($path, qw/.svn format/)) ? 1 : 0; |
---|
| 455 | |
---|
| 456 | } elsif (-f $path) { |
---|
| 457 | return (-e File::Spec->catfile (dirname ($path), qw/.svn format/)) ? 1 : 0; |
---|
| 458 | |
---|
| 459 | } else { |
---|
| 460 | return 0; |
---|
| 461 | } |
---|
| 462 | } |
---|
| 463 | |
---|
| 464 | # ------------------------------------------------------------------------------ |
---|
| 465 | # SYNOPSIS |
---|
| 466 | # $flag = &is_url ($url); |
---|
| 467 | # |
---|
| 468 | # DESCRIPTION |
---|
| 469 | # Returns true if $url is a URL. |
---|
| 470 | # ------------------------------------------------------------------------------ |
---|
| 471 | |
---|
| 472 | sub is_url { |
---|
| 473 | # This should handle URL beginning with svn://, http:// and svn+ssh:// |
---|
| 474 | return ($_[0] =~ m#^[\+\w]+://#); |
---|
| 475 | } |
---|
| 476 | |
---|
| 477 | # ------------------------------------------------------------------------------ |
---|
| 478 | # SYNOPSIS |
---|
| 479 | # $string = &get_wct ([$dir]); |
---|
| 480 | # |
---|
| 481 | # DESCRIPTION |
---|
| 482 | # If current working directory (or $dir) is a Subversion working copy, |
---|
| 483 | # returns the top directory of this working copy; otherwise returns an empty |
---|
| 484 | # string. |
---|
| 485 | # ------------------------------------------------------------------------------ |
---|
| 486 | |
---|
| 487 | sub get_wct { |
---|
| 488 | my $dir = @_ ? $_[0] : cwd (); |
---|
| 489 | |
---|
| 490 | return '' if not &is_wc ($dir); |
---|
| 491 | |
---|
| 492 | my $updir = dirname $dir; |
---|
| 493 | while (&is_wc ($updir)) { |
---|
| 494 | $dir = $updir; |
---|
| 495 | $updir = dirname $dir; |
---|
| 496 | last if $updir eq $dir; |
---|
| 497 | } |
---|
| 498 | |
---|
| 499 | return $dir; |
---|
| 500 | } |
---|
| 501 | |
---|
| 502 | # ------------------------------------------------------------------------------ |
---|
| 503 | # SYNOPSIS |
---|
| 504 | # $string = &get_url_of_wc ([$path[, $refresh]]); |
---|
| 505 | # |
---|
| 506 | # DESCRIPTION |
---|
| 507 | # If current working directory (or $path) is a Subversion working copy, |
---|
| 508 | # returns the URL of the associated Subversion repository; otherwise returns |
---|
| 509 | # an empty string. If $refresh is specified, do not use the cached |
---|
| 510 | # information. |
---|
| 511 | # ------------------------------------------------------------------------------ |
---|
| 512 | |
---|
| 513 | sub get_url_of_wc { |
---|
| 514 | my $path = @_ ? $_[0] : cwd (); |
---|
| 515 | my $refresh = exists $_[1] ? $_[1] : 0; |
---|
| 516 | my $url = ''; |
---|
| 517 | |
---|
| 518 | if (&is_wc ($path)) { |
---|
| 519 | delete $svn_info{$path} if $refresh; |
---|
| 520 | &_invoke_svn_info (PATH => $path) unless exists $svn_info{$path}; |
---|
| 521 | $url = $svn_info{$path}{URL}; |
---|
| 522 | } |
---|
| 523 | |
---|
| 524 | return $url; |
---|
| 525 | } |
---|
| 526 | |
---|
| 527 | # ------------------------------------------------------------------------------ |
---|
| 528 | # SYNOPSIS |
---|
| 529 | # &_invoke_svn_info (PATH => $path, [CFG => $cfg]); |
---|
| 530 | # |
---|
| 531 | # DESCRIPTION |
---|
| 532 | # The function is internal to this module. It invokes "svn info" on $path to |
---|
| 533 | # gather information on URL, Revision and Last Changed Rev. The information |
---|
| 534 | # is stored in a hash table at the module level, so that the information can |
---|
| 535 | # be re-used. If CFG is not set, it defaults to &main::cfg. |
---|
| 536 | # ------------------------------------------------------------------------------ |
---|
| 537 | |
---|
| 538 | sub _invoke_svn_info { |
---|
| 539 | my %args = @_; |
---|
| 540 | my $path = $args{PATH}; |
---|
| 541 | my $cfg = exists $args{CFG} ? $args{CFG} : &main::cfg; |
---|
| 542 | |
---|
| 543 | return if exists $svn_info{$path}; |
---|
| 544 | |
---|
| 545 | # Invoke "svn info" command |
---|
| 546 | my @info = &run_command ( |
---|
| 547 | [qw/svn info/, $path], |
---|
| 548 | PRINT => $cfg->verbose > 2, METHOD => 'qx', DEVNULL => 1, ERROR => 'ignore', |
---|
| 549 | ); |
---|
| 550 | for (@info) { |
---|
| 551 | chomp; |
---|
| 552 | |
---|
| 553 | if (/^(URL|Revision|Last Changed Rev):\s*(.+)$/) { |
---|
| 554 | $svn_info{$path}{$1} = $2; |
---|
| 555 | } |
---|
| 556 | } |
---|
| 557 | |
---|
| 558 | return; |
---|
| 559 | } |
---|
| 560 | |
---|
| 561 | # ------------------------------------------------------------------------------ |
---|
| 562 | # SYNOPSIS |
---|
| 563 | # $string = &get_command_string ($cmd); |
---|
| 564 | # $string = &get_command_string (\@cmd); |
---|
| 565 | # |
---|
| 566 | # DESCRIPTION |
---|
| 567 | # The function returns a string by converting the list in @cmd or the scalar |
---|
| 568 | # $cmd to a form, where it can be executed as a shell command. |
---|
| 569 | # ------------------------------------------------------------------------------ |
---|
| 570 | |
---|
| 571 | sub get_command_string { |
---|
| 572 | my $cmd = $_[0]; |
---|
| 573 | my $return = ''; |
---|
| 574 | |
---|
| 575 | if (ref ($cmd) and ref ($cmd) eq 'ARRAY') { |
---|
| 576 | # $cmd is a reference to an array |
---|
| 577 | |
---|
| 578 | # Print each argument |
---|
| 579 | for my $i (0 .. @{ $cmd } - 1) { |
---|
| 580 | my $arg = $cmd->[$i]; |
---|
| 581 | |
---|
| 582 | $arg =~ s/./*/g if $i > 0 and $cmd->[$i - 1] eq '--password'; |
---|
| 583 | |
---|
| 584 | if ($arg =~ /[\s'"*?]/) { |
---|
| 585 | # Argument contains a space, quote it |
---|
| 586 | if (index ($arg, "'") >= 0) { |
---|
| 587 | # Argument contains an apostrophe, quote it with double quotes |
---|
| 588 | $return .= ($i > 0 ? ' ' : '') . '"' . $arg . '"'; |
---|
| 589 | |
---|
| 590 | } else { |
---|
| 591 | # Otherwise, quote argument with apostrophes |
---|
| 592 | $return .= ($i > 0 ? ' ' : '') . "'" . $arg . "'"; |
---|
| 593 | } |
---|
| 594 | |
---|
| 595 | } else { |
---|
| 596 | # Argument does not contain a space, just print it |
---|
| 597 | $return .= ($i > 0 ? ' ' : '') . ($arg eq '' ? "''" : $arg); |
---|
| 598 | } |
---|
| 599 | } |
---|
| 600 | |
---|
| 601 | } else { |
---|
| 602 | # $cmd is a scalar, just print it "as is" |
---|
| 603 | $return = $cmd; |
---|
| 604 | } |
---|
| 605 | |
---|
| 606 | return $return; |
---|
| 607 | } |
---|
| 608 | |
---|
| 609 | # ------------------------------------------------------------------------------ |
---|
| 610 | # SYNOPSIS |
---|
| 611 | # &print_command ($cmd); |
---|
| 612 | # &print_command (\@cmd); |
---|
| 613 | # |
---|
| 614 | # DESCRIPTION |
---|
| 615 | # The function prints the list in @cmd or the scalar $cmd, as it would be |
---|
| 616 | # executed by the shell. |
---|
| 617 | # ------------------------------------------------------------------------------ |
---|
| 618 | |
---|
| 619 | sub print_command { |
---|
| 620 | my $cmd = $_[0]; |
---|
| 621 | |
---|
| 622 | print '=> ', &get_command_string ($cmd) , "\n"; |
---|
| 623 | } |
---|
| 624 | |
---|
| 625 | # ------------------------------------------------------------------------------ |
---|
| 626 | # SYNOPSIS |
---|
| 627 | # @return = &run_command (\@cmd, <OPTIONS>); |
---|
| 628 | # @return = &run_command ($cmd , <OPTIONS>); |
---|
| 629 | # |
---|
| 630 | # DESCRIPTION |
---|
| 631 | # This function executes the command in the list @cmd or in the scalar $cmd. |
---|
| 632 | # The remaining are optional arguments in a hash table. Valid options are |
---|
| 633 | # listed below. If the command is run using "qx", the function returns the |
---|
| 634 | # standard output from the command. If the command is run using "system", the |
---|
| 635 | # function returns true on success. By default, the function dies on failure. |
---|
| 636 | # |
---|
| 637 | # OPTIONS |
---|
| 638 | # METHOD => $method - this can be "system", "exec" or "qx". This determines |
---|
| 639 | # how the command will be executed. If not set, the |
---|
| 640 | # default is to run the command with "system". |
---|
| 641 | # PRINT => 1 - if set, print the command before executing it. |
---|
| 642 | # ERROR => $flag - this should only be set if METHOD is set to "system" |
---|
| 643 | # or "qx". The $flag can be "die" (default), "warn" or |
---|
| 644 | # "ignore". If set to "die", the function dies on error. |
---|
| 645 | # If set to "warn", the function issues a warning on |
---|
| 646 | # error, and the function returns false. If set to |
---|
| 647 | # "ignore", the function returns false on error. |
---|
| 648 | # RC => 1 - if set, must be a reference to a scalar, which will be |
---|
| 649 | # set to the return code of the command. |
---|
| 650 | # DEVNULL => 1 - if set, re-direct STDERR to /dev/null before running |
---|
| 651 | # the command. |
---|
| 652 | # TIME => 1 - if set, print the command with a timestamp before |
---|
| 653 | # executing it, and print the time taken when it |
---|
| 654 | # completes. This option supersedes the PRINT option. |
---|
| 655 | # ------------------------------------------------------------------------------ |
---|
| 656 | |
---|
| 657 | sub run_command { |
---|
| 658 | my $cmd = shift; |
---|
| 659 | my %options = @_; |
---|
| 660 | my $method = exists $options{METHOD} ? $options{METHOD} : 'system'; |
---|
| 661 | my $print = exists $options{PRINT} ? $options{PRINT} : undef; |
---|
| 662 | my $error = exists $options{ERROR} ? $options{ERROR} : 'die'; |
---|
| 663 | my $rc = exists $options{RC} ? $options{RC} : undef; |
---|
| 664 | my $devnull = exists $options{DEVNULL} ? $options{DEVNULL} : undef; |
---|
| 665 | my $time = exists $options{TIME} ? $options{TIME} : undef; |
---|
| 666 | my @return = (); |
---|
| 667 | |
---|
| 668 | # Check that the $error flag is set correctly |
---|
| 669 | $error = 'die' unless $error =~ /^(?:die|warn|ignore)$/i; |
---|
| 670 | |
---|
| 671 | # Print the command before execution, if necessary |
---|
| 672 | if ($time) { |
---|
| 673 | print ×tamp_command (&get_command_string ($cmd)); |
---|
| 674 | |
---|
| 675 | } elsif ($print) { |
---|
| 676 | &print_command ($cmd); |
---|
| 677 | } |
---|
| 678 | |
---|
| 679 | # Re-direct to /dev/null if necessary |
---|
| 680 | if ($devnull) { |
---|
| 681 | $devnull = File::Spec->devnull; |
---|
| 682 | |
---|
| 683 | # Save current STDERR |
---|
| 684 | no warnings; |
---|
| 685 | open OLDERR, ">&STDERR" or croak 'Cannot dup STDERR (', $!, '), abort'; |
---|
| 686 | use warnings; |
---|
| 687 | |
---|
| 688 | # Redirect STDERR to /dev/null |
---|
| 689 | open STDERR, '>', $devnull |
---|
| 690 | or croak 'Cannot redirect STDERR (', $!, '), abort'; |
---|
| 691 | |
---|
| 692 | # Make sure the channels are unbuffered |
---|
| 693 | my $select = select; |
---|
| 694 | select STDERR; $| = 1; |
---|
| 695 | select $select; |
---|
| 696 | } |
---|
| 697 | |
---|
| 698 | if (ref ($cmd) and ref ($cmd) eq 'ARRAY') { |
---|
| 699 | # $cmd is an array |
---|
| 700 | my @command = @{ $cmd }; |
---|
| 701 | |
---|
| 702 | if ($method eq 'qx') { |
---|
| 703 | @return = qx(@command); |
---|
| 704 | |
---|
| 705 | } elsif ($method eq 'exec') { |
---|
| 706 | exec (@command); |
---|
| 707 | |
---|
| 708 | } else { |
---|
| 709 | system (@command); |
---|
| 710 | @return = $? ? () : (1); |
---|
| 711 | } |
---|
| 712 | |
---|
| 713 | } else { |
---|
| 714 | # $cmd is an scalar |
---|
| 715 | if ($method eq 'qx') { |
---|
| 716 | @return = qx($cmd); |
---|
| 717 | |
---|
| 718 | } elsif ($method eq 'exec') { |
---|
| 719 | exec ($cmd); |
---|
| 720 | |
---|
| 721 | } else { |
---|
| 722 | system ($cmd); |
---|
| 723 | @return = $? ? () : (1); |
---|
| 724 | } |
---|
| 725 | } |
---|
| 726 | |
---|
| 727 | # Put STDERR back to normal, if redirected previously |
---|
| 728 | if ($devnull) { |
---|
| 729 | close STDERR; |
---|
| 730 | |
---|
| 731 | open STDERR, ">&OLDERR" or croak 'Cannot dup STDERR (', $!, '), abort'; |
---|
| 732 | } |
---|
| 733 | |
---|
| 734 | # Print the time taken for command after execution, if necessary |
---|
| 735 | print ×tamp_command (&get_command_string ($cmd), 'end') if $time; |
---|
| 736 | |
---|
| 737 | if ($?) { |
---|
| 738 | # The command has failed |
---|
| 739 | if ($error eq 'die') { |
---|
| 740 | # Throw fatal error if ERROR is set to "die" |
---|
| 741 | croak &get_command_string ($cmd), ' failed (', $?, ')'; |
---|
| 742 | |
---|
| 743 | } elsif ($error eq 'warn') { |
---|
| 744 | # Issue warning if ERROR is set to "warn" |
---|
| 745 | carp &get_command_string ($cmd), ' failed (', $?, ')'; |
---|
| 746 | } |
---|
| 747 | } |
---|
| 748 | |
---|
| 749 | # Set the return code if necessary |
---|
| 750 | $$rc = $? if $rc; |
---|
| 751 | |
---|
| 752 | return @return; |
---|
| 753 | } |
---|
| 754 | |
---|
| 755 | # ------------------------------------------------------------------------------ |
---|
| 756 | # SYNOPSIS |
---|
| 757 | # &e_report (@message); |
---|
| 758 | # |
---|
| 759 | # DESCRIPTION |
---|
| 760 | # The function prints @message to STDERR and aborts with a error. |
---|
| 761 | # ------------------------------------------------------------------------------ |
---|
| 762 | |
---|
| 763 | sub e_report { |
---|
| 764 | print STDERR @_, "\n" if @_; |
---|
| 765 | |
---|
| 766 | exit 1; |
---|
| 767 | } |
---|
| 768 | |
---|
| 769 | # ------------------------------------------------------------------------------ |
---|
| 770 | # SYNOPSIS |
---|
| 771 | # &w_report (@message); |
---|
| 772 | # |
---|
| 773 | # DESCRIPTION |
---|
| 774 | # The function prints @message to STDERR and returns. |
---|
| 775 | # ------------------------------------------------------------------------------ |
---|
| 776 | |
---|
| 777 | sub w_report { |
---|
| 778 | print STDERR @_, "\n" if @_; |
---|
| 779 | |
---|
| 780 | return; |
---|
| 781 | } |
---|
| 782 | |
---|
| 783 | # ------------------------------------------------------------------------------ |
---|
| 784 | # SYNOPSIS |
---|
| 785 | # $date = &svn_date ($time); |
---|
| 786 | # |
---|
| 787 | # DESCRIPTION |
---|
| 788 | # The function returns a date, formatted as by Subversion. The argument $time |
---|
| 789 | # is the number of seconds since epoch. |
---|
| 790 | # ------------------------------------------------------------------------------ |
---|
| 791 | |
---|
| 792 | sub svn_date { |
---|
| 793 | my $time = shift; |
---|
| 794 | |
---|
| 795 | return strftime ('%Y-%m-%d %H:%M:%S %z (%a, %d %b %Y)', localtime ($time)); |
---|
| 796 | } |
---|
| 797 | |
---|
| 798 | # ------------------------------------------------------------------------------ |
---|
| 799 | |
---|
| 800 | 1; |
---|
| 801 | |
---|
| 802 | __END__ |
---|