[1980] | 1 | # ------------------------------------------------------------------------------ |
---|
| 2 | # NAME |
---|
| 3 | # Fcm::Util |
---|
| 4 | # |
---|
| 5 | # DESCRIPTION |
---|
| 6 | # This is a package of misc utilities used by the FCM command. |
---|
| 7 | # |
---|
| 8 | # COPYRIGHT |
---|
| 9 | # (C) Crown copyright Met Office. All rights reserved. |
---|
| 10 | # For further details please refer to the file COPYRIGHT.txt |
---|
| 11 | # which you should have received as part of this distribution. |
---|
| 12 | # ------------------------------------------------------------------------------ |
---|
| 13 | |
---|
| 14 | use warnings; |
---|
| 15 | use strict; |
---|
| 16 | |
---|
| 17 | package Fcm::Util; |
---|
| 18 | require Exporter; |
---|
| 19 | our @ISA = qw{Exporter}; |
---|
| 20 | |
---|
| 21 | sub expand_tilde; |
---|
| 22 | sub e_report; |
---|
| 23 | sub find_file_in_path; |
---|
| 24 | sub get_command_string; |
---|
| 25 | sub get_rev_of_wc; |
---|
| 26 | sub get_url_of_wc; |
---|
| 27 | sub get_url_peg_of_wc; |
---|
| 28 | sub get_wct; |
---|
| 29 | sub is_url; |
---|
| 30 | sub is_wc; |
---|
| 31 | sub print_command; |
---|
| 32 | sub run_command; |
---|
| 33 | sub svn_date; |
---|
| 34 | sub tidy_url; |
---|
| 35 | sub touch_file; |
---|
| 36 | sub w_report; |
---|
| 37 | |
---|
| 38 | our @EXPORT = qw{ |
---|
| 39 | expand_tilde |
---|
| 40 | e_report |
---|
| 41 | find_file_in_path |
---|
| 42 | get_command_string |
---|
| 43 | get_rev_of_wc |
---|
| 44 | get_url_of_wc |
---|
| 45 | get_url_peg_of_wc |
---|
| 46 | get_wct |
---|
| 47 | is_url |
---|
| 48 | is_wc |
---|
| 49 | print_command |
---|
| 50 | run_command |
---|
| 51 | svn_date |
---|
| 52 | tidy_url |
---|
| 53 | touch_file |
---|
| 54 | w_report |
---|
| 55 | }; |
---|
| 56 | |
---|
| 57 | # Standard modules |
---|
| 58 | use Carp; |
---|
| 59 | use Cwd; |
---|
| 60 | use File::Basename; |
---|
| 61 | use File::Find; |
---|
| 62 | use File::Path; |
---|
| 63 | use File::Spec; |
---|
| 64 | use POSIX qw{strftime SIGINT SIGKILL SIGTERM WEXITSTATUS WIFSIGNALED WTERMSIG}; |
---|
| 65 | |
---|
| 66 | # FCM component modules |
---|
| 67 | use Fcm::Timer; |
---|
| 68 | |
---|
| 69 | # ------------------------------------------------------------------------------ |
---|
| 70 | |
---|
| 71 | # Module level variables |
---|
| 72 | my %svn_info = (); # "svn info" log, (key1 = path, |
---|
| 73 | # key2 = URL, Revision, Last Changed Rev) |
---|
| 74 | |
---|
| 75 | # ------------------------------------------------------------------------------ |
---|
| 76 | # SYNOPSIS |
---|
| 77 | # %srcdir = &Fcm::Util::find_file_in_path ($file, \@path); |
---|
| 78 | # |
---|
| 79 | # DESCRIPTION |
---|
| 80 | # Search $file in @path. Returns the full path of the $file if it is found |
---|
| 81 | # in @path. Returns "undef" if $file is not found in @path. |
---|
| 82 | # ------------------------------------------------------------------------------ |
---|
| 83 | |
---|
| 84 | sub find_file_in_path { |
---|
| 85 | my ($file, $path) = @_; |
---|
| 86 | |
---|
| 87 | for my $dir (@$path) { |
---|
| 88 | my $full_file = File::Spec->catfile ($dir, $file); |
---|
| 89 | return $full_file if -e $full_file; |
---|
| 90 | } |
---|
| 91 | |
---|
| 92 | return undef; |
---|
| 93 | } |
---|
| 94 | |
---|
| 95 | # ------------------------------------------------------------------------------ |
---|
| 96 | # SYNOPSIS |
---|
| 97 | # $expanded_path = &Fcm::Util::expand_tilde ($path); |
---|
| 98 | # |
---|
| 99 | # DESCRIPTION |
---|
| 100 | # Returns an expanded path if $path is a path that begins with a tilde (~). |
---|
| 101 | # ------------------------------------------------------------------------------ |
---|
| 102 | |
---|
| 103 | sub expand_tilde { |
---|
| 104 | my $file = $_[0]; |
---|
| 105 | |
---|
| 106 | $file =~ s#^~([^/]*)#$1 ? (getpwnam $1)[7] : ($ENV{HOME} || $ENV{LOGDIR})#ex; |
---|
| 107 | |
---|
| 108 | # Expand . and .. |
---|
| 109 | while ($file =~ s#/+\.(?:/+|$)#/#g) {next} |
---|
| 110 | while ($file =~ s#/+[^/]+/+\.\.(?:/+|$)#/#g) {next} |
---|
| 111 | |
---|
| 112 | # Remove trailing / |
---|
| 113 | $file =~ s#/*$##; |
---|
| 114 | |
---|
| 115 | return $file; |
---|
| 116 | } |
---|
| 117 | |
---|
| 118 | # ------------------------------------------------------------------------------ |
---|
| 119 | # SYNOPSIS |
---|
| 120 | # $rc = &Fcm::Util::touch_file ($file); |
---|
| 121 | # |
---|
| 122 | # DESCRIPTION |
---|
| 123 | # Touch $file if it exists. Create $file if it does not exist. Return 1 for |
---|
| 124 | # success or 0 otherwise. |
---|
| 125 | # ------------------------------------------------------------------------------ |
---|
| 126 | |
---|
| 127 | sub touch_file { |
---|
| 128 | my $file = $_[0]; |
---|
| 129 | my $rc = 1; |
---|
| 130 | |
---|
| 131 | if (-e $file) { |
---|
| 132 | my $now = time; |
---|
| 133 | $rc = utime $now, $now, $file; |
---|
| 134 | |
---|
| 135 | } else { |
---|
| 136 | mkpath dirname ($file) unless -d dirname ($file); |
---|
| 137 | |
---|
| 138 | $rc = open FILE, '>', $file; |
---|
| 139 | $rc = close FILE if $rc; |
---|
| 140 | } |
---|
| 141 | |
---|
| 142 | return $rc; |
---|
| 143 | } |
---|
| 144 | |
---|
| 145 | # ------------------------------------------------------------------------------ |
---|
| 146 | # SYNOPSIS |
---|
| 147 | # $flag = &is_wc ([$path]); |
---|
| 148 | # |
---|
| 149 | # DESCRIPTION |
---|
| 150 | # Returns true if current working directory (or $path) is a Subversion |
---|
| 151 | # working copy. |
---|
| 152 | # ------------------------------------------------------------------------------ |
---|
| 153 | |
---|
| 154 | sub is_wc { |
---|
| 155 | my $path = @_ ? $_[0] : cwd (); |
---|
| 156 | |
---|
| 157 | if (-d $path) { |
---|
| 158 | return (-e File::Spec->catfile ($path, qw/.svn format/)) ? 1 : 0; |
---|
| 159 | |
---|
| 160 | } elsif (-f $path) { |
---|
| 161 | return (-e File::Spec->catfile (dirname ($path), qw/.svn format/)) ? 1 : 0; |
---|
| 162 | |
---|
| 163 | } else { |
---|
| 164 | return 0; |
---|
| 165 | } |
---|
| 166 | } |
---|
| 167 | |
---|
| 168 | # ------------------------------------------------------------------------------ |
---|
| 169 | # SYNOPSIS |
---|
| 170 | # $flag = &is_url ($url); |
---|
| 171 | # |
---|
| 172 | # DESCRIPTION |
---|
| 173 | # Returns true if $url is a URL. |
---|
| 174 | # ------------------------------------------------------------------------------ |
---|
| 175 | |
---|
| 176 | sub is_url { |
---|
| 177 | # This should handle URL beginning with svn://, http:// and svn+ssh:// |
---|
| 178 | return ($_[0] =~ m#^[\+\w]+://#); |
---|
| 179 | } |
---|
| 180 | |
---|
| 181 | # ------------------------------------------------------------------------------ |
---|
| 182 | # SYNOPSIS |
---|
| 183 | # $url = tidy_url($url); |
---|
| 184 | # |
---|
| 185 | # DESCRIPTION |
---|
| 186 | # Returns a tidied version of $url by removing . and .. in the path. |
---|
| 187 | # ------------------------------------------------------------------------------ |
---|
| 188 | |
---|
| 189 | sub tidy_url { |
---|
| 190 | my ($url) = @_; |
---|
| 191 | if (!is_url($url)) { |
---|
| 192 | return $url; |
---|
| 193 | } |
---|
| 194 | my $DOT_PATTERN = qr{/+ \. (?:/+|(@|\z))}xms; |
---|
| 195 | my $DOT_DOT_PATTERN = qr{/+ [^/]+ /+ \.\. (?:/+|(@|\z))}xms; |
---|
| 196 | my $TRAILING_SLASH_PATTERN = qr{([^/]+) /* (@|\z)}xms; |
---|
| 197 | my $RIGHT_EVAL = q{'/' . ($1 ? $1 : '')}; |
---|
| 198 | DOT: |
---|
| 199 | while ($url =~ s{$DOT_PATTERN}{$RIGHT_EVAL}eegxms) { |
---|
| 200 | next DOT; |
---|
| 201 | } |
---|
| 202 | DOT_DOT: |
---|
| 203 | while ($url =~ s{$DOT_DOT_PATTERN}{$RIGHT_EVAL}eegxms) { |
---|
| 204 | next DOT_DOT; |
---|
| 205 | } |
---|
| 206 | $url =~ s{$TRAILING_SLASH_PATTERN}{$1$2}xms; |
---|
| 207 | return $url; |
---|
| 208 | } |
---|
| 209 | |
---|
| 210 | # ------------------------------------------------------------------------------ |
---|
| 211 | # SYNOPSIS |
---|
| 212 | # $string = &get_wct ([$dir]); |
---|
| 213 | # |
---|
| 214 | # DESCRIPTION |
---|
| 215 | # If current working directory (or $dir) is a Subversion working copy, |
---|
| 216 | # returns the top directory of this working copy; otherwise returns an empty |
---|
| 217 | # string. |
---|
| 218 | # ------------------------------------------------------------------------------ |
---|
| 219 | |
---|
| 220 | sub get_wct { |
---|
| 221 | my $dir = @_ ? $_[0] : cwd (); |
---|
| 222 | |
---|
| 223 | return '' if not &is_wc ($dir); |
---|
| 224 | |
---|
| 225 | my $updir = dirname $dir; |
---|
| 226 | while (&is_wc ($updir)) { |
---|
| 227 | $dir = $updir; |
---|
| 228 | $updir = dirname $dir; |
---|
| 229 | last if $updir eq $dir; |
---|
| 230 | } |
---|
| 231 | |
---|
| 232 | return $dir; |
---|
| 233 | } |
---|
| 234 | |
---|
| 235 | # ------------------------------------------------------------------------------ |
---|
| 236 | # SYNOPSIS |
---|
| 237 | # $string = &get_url_of_wc ([$path[, $refresh]]); |
---|
| 238 | # |
---|
| 239 | # DESCRIPTION |
---|
| 240 | # If current working directory (or $path) is a Subversion working copy, |
---|
| 241 | # returns the URL of the associated Subversion repository; otherwise returns |
---|
| 242 | # an empty string. If $refresh is specified, do not use the cached |
---|
| 243 | # information. |
---|
| 244 | # ------------------------------------------------------------------------------ |
---|
| 245 | |
---|
| 246 | sub get_url_of_wc { |
---|
| 247 | my $path = @_ ? $_[0] : cwd (); |
---|
| 248 | my $refresh = exists $_[1] ? $_[1] : 0; |
---|
| 249 | my $url = ''; |
---|
| 250 | |
---|
| 251 | if (&is_wc ($path)) { |
---|
| 252 | delete $svn_info{$path} if $refresh; |
---|
| 253 | &_invoke_svn_info (PATH => $path) unless exists $svn_info{$path}; |
---|
| 254 | $url = $svn_info{$path}{URL}; |
---|
| 255 | } |
---|
| 256 | |
---|
| 257 | return $url; |
---|
| 258 | } |
---|
| 259 | |
---|
| 260 | # ------------------------------------------------------------------------------ |
---|
| 261 | # SYNOPSIS |
---|
| 262 | # $string = &get_url_peg_of_wc ([$path[, $refresh]]); |
---|
| 263 | # |
---|
| 264 | # DESCRIPTION |
---|
| 265 | # If current working directory (or $path) is a Subversion working copy, |
---|
| 266 | # returns the URL@REV of the associated Subversion repository; otherwise |
---|
| 267 | # returns an empty string. If $refresh is specified, do not use the cached |
---|
| 268 | # information. |
---|
| 269 | # ------------------------------------------------------------------------------ |
---|
| 270 | |
---|
| 271 | sub get_url_peg_of_wc { |
---|
| 272 | my $path = @_ ? $_[0] : cwd (); |
---|
| 273 | my $refresh = exists $_[1] ? $_[1] : 0; |
---|
| 274 | my $url = ''; |
---|
| 275 | |
---|
| 276 | if (&is_wc ($path)) { |
---|
| 277 | delete $svn_info{$path} if $refresh; |
---|
| 278 | &_invoke_svn_info (PATH => $path) unless exists $svn_info{$path}; |
---|
| 279 | $url = $svn_info{$path}{URL} . '@' . $svn_info{$path}{Revision}; |
---|
| 280 | } |
---|
| 281 | |
---|
| 282 | return $url; |
---|
| 283 | } |
---|
| 284 | |
---|
| 285 | # ------------------------------------------------------------------------------ |
---|
| 286 | # SYNOPSIS |
---|
| 287 | # &_invoke_svn_info (PATH => $path); |
---|
| 288 | # |
---|
| 289 | # DESCRIPTION |
---|
| 290 | # The function is internal to this module. It invokes "svn info" on $path to |
---|
| 291 | # gather information on URL, Revision and Last Changed Rev. The information |
---|
| 292 | # is stored in a hash table at the module level, so that the information can |
---|
| 293 | # be re-used. |
---|
| 294 | # ------------------------------------------------------------------------------ |
---|
| 295 | |
---|
| 296 | sub _invoke_svn_info { |
---|
| 297 | my %args = @_; |
---|
| 298 | my $path = $args{PATH}; |
---|
| 299 | my $cfg = Fcm::Config->instance(); |
---|
| 300 | |
---|
| 301 | return if exists $svn_info{$path}; |
---|
| 302 | |
---|
| 303 | # Invoke "svn info" command |
---|
| 304 | my @info = &run_command ( |
---|
| 305 | [qw/svn info/, $path], |
---|
| 306 | PRINT => $cfg->verbose > 2, METHOD => 'qx', DEVNULL => 1, ERROR => 'ignore', |
---|
| 307 | ); |
---|
| 308 | for (@info) { |
---|
| 309 | chomp; |
---|
| 310 | |
---|
| 311 | if (/^(URL|Revision|Last Changed Rev):\s*(.+)$/) { |
---|
| 312 | $svn_info{$path}{$1} = $2; |
---|
| 313 | } |
---|
| 314 | } |
---|
| 315 | |
---|
| 316 | return; |
---|
| 317 | } |
---|
| 318 | |
---|
| 319 | # ------------------------------------------------------------------------------ |
---|
| 320 | # SYNOPSIS |
---|
| 321 | # $string = &get_command_string ($cmd); |
---|
| 322 | # $string = &get_command_string (\@cmd); |
---|
| 323 | # |
---|
| 324 | # DESCRIPTION |
---|
| 325 | # The function returns a string by converting the list in @cmd or the scalar |
---|
| 326 | # $cmd to a form, where it can be executed as a shell command. |
---|
| 327 | # ------------------------------------------------------------------------------ |
---|
| 328 | |
---|
| 329 | sub get_command_string { |
---|
| 330 | my $cmd = $_[0]; |
---|
| 331 | my $return = ''; |
---|
| 332 | |
---|
| 333 | if (ref ($cmd) and ref ($cmd) eq 'ARRAY') { |
---|
| 334 | # $cmd is a reference to an array |
---|
| 335 | |
---|
| 336 | # Print each argument |
---|
| 337 | for my $i (0 .. @{ $cmd } - 1) { |
---|
| 338 | my $arg = $cmd->[$i]; |
---|
| 339 | |
---|
| 340 | $arg =~ s/./*/g if $i > 0 and $cmd->[$i - 1] eq '--password'; |
---|
| 341 | |
---|
| 342 | if ($arg =~ /[\s'"*?]/) { |
---|
| 343 | # Argument contains a space, quote it |
---|
| 344 | if (index ($arg, "'") >= 0) { |
---|
| 345 | # Argument contains an apostrophe, quote it with double quotes |
---|
| 346 | $return .= ($i > 0 ? ' ' : '') . '"' . $arg . '"'; |
---|
| 347 | |
---|
| 348 | } else { |
---|
| 349 | # Otherwise, quote argument with apostrophes |
---|
| 350 | $return .= ($i > 0 ? ' ' : '') . "'" . $arg . "'"; |
---|
| 351 | } |
---|
| 352 | |
---|
| 353 | } else { |
---|
| 354 | # Argument does not contain a space, just print it |
---|
| 355 | $return .= ($i > 0 ? ' ' : '') . ($arg eq '' ? "''" : $arg); |
---|
| 356 | } |
---|
| 357 | } |
---|
| 358 | |
---|
| 359 | } else { |
---|
| 360 | # $cmd is a scalar, just print it "as is" |
---|
| 361 | $return = $cmd; |
---|
| 362 | } |
---|
| 363 | |
---|
| 364 | return $return; |
---|
| 365 | } |
---|
| 366 | |
---|
| 367 | # ------------------------------------------------------------------------------ |
---|
| 368 | # SYNOPSIS |
---|
| 369 | # &print_command ($cmd); |
---|
| 370 | # &print_command (\@cmd); |
---|
| 371 | # |
---|
| 372 | # DESCRIPTION |
---|
| 373 | # The function prints the list in @cmd or the scalar $cmd, as it would be |
---|
| 374 | # executed by the shell. |
---|
| 375 | # ------------------------------------------------------------------------------ |
---|
| 376 | |
---|
| 377 | sub print_command { |
---|
| 378 | my $cmd = $_[0]; |
---|
| 379 | |
---|
| 380 | print '=> ', &get_command_string ($cmd) , "\n"; |
---|
| 381 | } |
---|
| 382 | |
---|
| 383 | # ------------------------------------------------------------------------------ |
---|
| 384 | # SYNOPSIS |
---|
| 385 | # @return = &run_command (\@cmd, <OPTIONS>); |
---|
| 386 | # @return = &run_command ($cmd , <OPTIONS>); |
---|
| 387 | # |
---|
| 388 | # DESCRIPTION |
---|
| 389 | # This function executes the command in the list @cmd or in the scalar $cmd. |
---|
| 390 | # The remaining are optional arguments in a hash table. Valid options are |
---|
| 391 | # listed below. If the command is run using "qx", the function returns the |
---|
| 392 | # standard output from the command. If the command is run using "system", the |
---|
| 393 | # function returns true on success. By default, the function dies on failure. |
---|
| 394 | # |
---|
| 395 | # OPTIONS |
---|
| 396 | # METHOD => $method - this can be "system", "exec" or "qx". This determines |
---|
| 397 | # how the command will be executed. If not set, the |
---|
| 398 | # default is to run the command with "system". |
---|
| 399 | # PRINT => 1 - if set, print the command before executing it. |
---|
| 400 | # ERROR => $flag - this should only be set if METHOD is set to "system" |
---|
| 401 | # or "qx". The $flag can be "die" (default), "warn" or |
---|
| 402 | # "ignore". If set to "die", the function dies on error. |
---|
| 403 | # If set to "warn", the function issues a warning on |
---|
| 404 | # error, and the function returns false. If set to |
---|
| 405 | # "ignore", the function returns false on error. |
---|
| 406 | # RC => 1 - if set, must be a reference to a scalar, which will be |
---|
| 407 | # set to the return code of the command. |
---|
| 408 | # DEVNULL => 1 - if set, re-direct STDERR to /dev/null before running |
---|
| 409 | # the command. |
---|
| 410 | # TIME => 1 - if set, print the command with a timestamp before |
---|
| 411 | # executing it, and print the time taken when it |
---|
| 412 | # completes. This option supersedes the PRINT option. |
---|
| 413 | # ------------------------------------------------------------------------------ |
---|
| 414 | |
---|
| 415 | sub run_command { |
---|
| 416 | my ($cmd, %input_opt_of) = @_; |
---|
| 417 | my %opt_of = ( |
---|
| 418 | DEVNULL => undef, |
---|
| 419 | ERROR => 'die', |
---|
| 420 | METHOD => 'system', |
---|
| 421 | PRINT => undef, |
---|
| 422 | RC => undef, |
---|
| 423 | TIME => undef, |
---|
| 424 | %input_opt_of, |
---|
| 425 | ); |
---|
| 426 | local($|) = 1; # Make sure STDOUT is flushed before running command |
---|
| 427 | |
---|
| 428 | # Print the command before execution, if necessary |
---|
| 429 | if ($opt_of{TIME}) { |
---|
| 430 | print(timestamp_command(get_command_string($cmd))); |
---|
| 431 | } |
---|
| 432 | elsif ($opt_of{PRINT}) { |
---|
| 433 | print_command($cmd); |
---|
| 434 | } |
---|
| 435 | |
---|
| 436 | # Re-direct STDERR to /dev/null if necessary |
---|
| 437 | if ($opt_of{DEVNULL}) { |
---|
| 438 | no warnings; |
---|
| 439 | open(OLDERR, ">&STDERR") || croak("Cannot dup STDERR ($!), abort"); |
---|
| 440 | use warnings; |
---|
| 441 | open(STDERR, '>', File::Spec->devnull()) |
---|
| 442 | || croak("Cannot redirect STDERR ($!), abort"); |
---|
| 443 | # Make sure the channels are unbuffered |
---|
| 444 | my $select = select(); |
---|
| 445 | select(STDERR); local($|) = 1; |
---|
| 446 | select($select); |
---|
| 447 | } |
---|
| 448 | |
---|
| 449 | my @return = (); |
---|
| 450 | if (ref($cmd) && ref($cmd) eq 'ARRAY') { |
---|
| 451 | # $cmd is an array |
---|
| 452 | my @command = @{$cmd}; |
---|
| 453 | if ($opt_of{METHOD} eq 'qx') { |
---|
| 454 | @return = qx(@command); |
---|
| 455 | } |
---|
| 456 | elsif ($opt_of{METHOD} eq 'exec') { |
---|
| 457 | exec(@command); |
---|
| 458 | } |
---|
| 459 | else { |
---|
| 460 | system(@command); |
---|
| 461 | @return = $? ? () : (1); |
---|
| 462 | } |
---|
| 463 | } |
---|
| 464 | else { |
---|
| 465 | # $cmd is an scalar |
---|
| 466 | if ($opt_of{METHOD} eq 'qx') { |
---|
| 467 | @return = qx($cmd); |
---|
| 468 | } |
---|
| 469 | elsif ($opt_of{METHOD} eq 'exec') { |
---|
| 470 | exec($cmd); |
---|
| 471 | } |
---|
| 472 | else { |
---|
| 473 | system($cmd); |
---|
| 474 | @return = $? ? () : (1); |
---|
| 475 | } |
---|
| 476 | } |
---|
| 477 | my $rc = $?; |
---|
| 478 | |
---|
| 479 | # Put STDERR back to normal, if redirected previously |
---|
| 480 | if ($opt_of{DEVNULL}) { |
---|
| 481 | close(STDERR); |
---|
| 482 | open(STDERR, ">&OLDERR") || croak("Cannot dup STDERR ($!), abort"); |
---|
| 483 | } |
---|
| 484 | |
---|
| 485 | # Print the time taken for command after execution, if necessary |
---|
| 486 | if ($opt_of{TIME}) { |
---|
| 487 | print(timestamp_command(get_command_string($cmd), 'end')); |
---|
| 488 | } |
---|
| 489 | |
---|
| 490 | # Signal and return code |
---|
| 491 | my ($signal, $status) = (WTERMSIG($rc), WEXITSTATUS($rc)); |
---|
| 492 | if (exists($opt_of{RC})) { |
---|
| 493 | ${$opt_of{RC}} = $status; |
---|
| 494 | } |
---|
| 495 | if (WIFSIGNALED($rc) && grep {$signal == $_} (SIGINT, SIGKILL, SIGTERM)) { |
---|
| 496 | croak(sprintf('%s terminated (%d)', get_command_string($cmd), $signal)); |
---|
| 497 | } |
---|
| 498 | if ($status && $opt_of{ERROR} ne 'ignore') { |
---|
| 499 | my $func_ref = $opt_of{ERROR} eq 'warn' ? \&carp : \&croak; |
---|
| 500 | $func_ref->(sprintf('%s failed (%d)', get_command_string($cmd), $status)); |
---|
| 501 | } |
---|
| 502 | return @return; |
---|
| 503 | } |
---|
| 504 | |
---|
| 505 | # ------------------------------------------------------------------------------ |
---|
| 506 | # SYNOPSIS |
---|
| 507 | # &e_report (@message); |
---|
| 508 | # |
---|
| 509 | # DESCRIPTION |
---|
| 510 | # The function prints @message to STDERR and aborts with a error. |
---|
| 511 | # ------------------------------------------------------------------------------ |
---|
| 512 | |
---|
| 513 | sub e_report { |
---|
| 514 | print STDERR @_, "\n" if @_; |
---|
| 515 | |
---|
| 516 | exit 1; |
---|
| 517 | } |
---|
| 518 | |
---|
| 519 | # ------------------------------------------------------------------------------ |
---|
| 520 | # SYNOPSIS |
---|
| 521 | # &w_report (@message); |
---|
| 522 | # |
---|
| 523 | # DESCRIPTION |
---|
| 524 | # The function prints @message to STDERR and returns. |
---|
| 525 | # ------------------------------------------------------------------------------ |
---|
| 526 | |
---|
| 527 | sub w_report { |
---|
| 528 | print STDERR @_, "\n" if @_; |
---|
| 529 | |
---|
| 530 | return; |
---|
| 531 | } |
---|
| 532 | |
---|
| 533 | # ------------------------------------------------------------------------------ |
---|
| 534 | # SYNOPSIS |
---|
| 535 | # $date = &svn_date ($time); |
---|
| 536 | # |
---|
| 537 | # DESCRIPTION |
---|
| 538 | # The function returns a date, formatted as by Subversion. The argument $time |
---|
| 539 | # is the number of seconds since epoch. |
---|
| 540 | # ------------------------------------------------------------------------------ |
---|
| 541 | |
---|
| 542 | sub svn_date { |
---|
| 543 | my $time = shift; |
---|
| 544 | |
---|
| 545 | return strftime ('%Y-%m-%d %H:%M:%S %z (%a, %d %b %Y)', localtime ($time)); |
---|
| 546 | } |
---|
| 547 | |
---|
| 548 | # ------------------------------------------------------------------------------ |
---|
| 549 | |
---|
| 550 | 1; |
---|
| 551 | |
---|
| 552 | __END__ |
---|