source: codes/icosagcm/trunk/tools/FCM/lib/Fcm/Util.pm @ 10

Last change on this file since 10 was 10, checked in by ymipsl, 12 years ago

dynamico tree creation

YM
File size: 22.7 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_wct;
36sub is_url;
37sub is_wc;
38sub print_command;
39sub run_command;
40sub svn_date;
41sub touch_file;
42sub w_report;
43
44require 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
69use Carp;
70use Cwd;
71use File::Basename;
72use File::Find;
73use File::Path;
74use File::Spec;
75use POSIX qw/strftime/;
76
77# FCM component modules
78use Fcm::Timer;
79
80# ------------------------------------------------------------------------------
81
82# Module level variables
83my %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
101sub 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
175sub 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
194sub 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
211sub 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
240sub 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
286sub 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
354sub 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
407sub 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
450sub 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
472sub 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
487sub 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
513sub 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
538sub _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
571sub 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
619sub 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
657sub 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 &timestamp_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 &timestamp_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
763sub 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
777sub 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
792sub 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
8001;
801
802__END__
Note: See TracBrowser for help on using the repository browser.