New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Util.pm in branches/UKMO/r6232_tracer_advection/NEMOGCM/EXTERNAL/fcm/lib/Fcm – NEMO

source: branches/UKMO/r6232_tracer_advection/NEMOGCM/EXTERNAL/fcm/lib/Fcm/Util.pm @ 9294

Last change on this file since 9294 was 2281, checked in by smasson, 13 years ago

set proper svn properties to all files...

  • Property svn:keywords set to Id
File size: 15.4 KB
Line 
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
14use warnings;
15use strict;
16
17package Fcm::Util;
18require Exporter;
19our @ISA = qw{Exporter};
20
21sub expand_tilde;
22sub e_report;
23sub find_file_in_path;
24sub get_command_string;
25sub get_rev_of_wc;
26sub get_url_of_wc;
27sub get_url_peg_of_wc;
28sub get_wct;
29sub is_url;
30sub is_wc;
31sub print_command;
32sub run_command;
33sub svn_date;
34sub tidy_url;
35sub touch_file;
36sub w_report;
37
38our @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
58use Carp;
59use Cwd;
60use File::Basename;
61use File::Find;
62use File::Path;
63use File::Spec;
64use POSIX qw{strftime SIGINT SIGKILL SIGTERM WEXITSTATUS WIFSIGNALED WTERMSIG};
65
66# FCM component modules
67use Fcm::Timer;
68
69# ------------------------------------------------------------------------------
70
71# Module level variables
72my %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
84sub 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
103sub 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
127sub 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
154sub 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
176sub 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
189sub 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
220sub 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
246sub 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
271sub 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
296sub _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
329sub 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
377sub 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
415sub 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
513sub 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
527sub 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
542sub 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
5501;
551
552__END__
Note: See TracBrowser for help on using the repository browser.