source: LMDZ6/branches/contrails/tools/fcm/lib/Fcm/Util.pm @ 5433

Last change on this file since 5433 was 1578, checked in by jghattas, 13 years ago
  • Add fcm in LMDZ5/tools directory

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