source: LMDZ6/branches/LMDZ-QUEST/tools/fcm/bin/fcm_update_version_dir.pl @ 3582

Last change on this file since 3582 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.

  • Property svn:executable set to *
File size: 8.9 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   fcm_update_version_dir.pl
5#
6# SYNOPSIS
7#   fcm_update_version_dir.pl [OPTIONS] [CFGFILE]
8#
9# DESCRIPTION
10#   See $usage for detail.
11#
12# COPYRIGHT
13#   (C) Crown copyright Met Office. All rights reserved.
14#   For further details please refer to the file COPYRIGHT.txt
15#   which you should have received as part of this distribution.
16# ------------------------------------------------------------------------------
17
18# Standard pragmas
19use strict;
20use warnings;
21
22# Standard modules
23use Getopt::Long;
24use Cwd;
25use File::Basename;
26use File::Path;
27use File::Spec;
28
29# FCM component modules:
30use lib File::Spec->catfile (dirname (dirname ($0)), 'lib');
31use Fcm::Config;
32use Fcm::Util;
33
34# Usage
35# ------------------------------------------------------------------------------
36my $this  = basename $0;
37my $usage = <<EOF;
38NAME
39  $this
40
41SYNOPSIS
42  $this [OPTIONS] [CFGFILE]
43
44DESCRIPTION
45  Update the version directories for a list of relative paths in the source
46  repository URL.
47
48OPTIONS
49  -d [--dest] arg: Specify a destination for the extraction. If not specified,
50                   the command extracts to the current working directory.
51  -h [--help]    : Print help and exit.
52  -f [--full]    : Specify the full mode. If not specified, the command runs
53                   in incremental mode.
54  -u [--url]  arg: Specify the source repository URL. No default.
55
56ARGUMENTS
57  A configuration file may be given to this command, or it will attempt to
58  read from the standard input. Each line in the configuration must contain
59  a relative path that resides under the given source repository URL. (Empty
60  lines and lines beginning with a "#" are ignored.) Optionally, each
61  relative path may be followed by a list of space separated "conditions".
62  Each condition is a conditional operator (>, >=, <, <=, == or !=) followed
63  by a revision number or the keyword HEAD. The command uses the revision
64  log to determine the revisions at which the relative path has been updated
65  in the source repository URL. If these revisions also satisfy the
66  "conditions" set by the user, they will be considered in the extraction.
67  In full mode, everything is re-extracted. In incremental mode, the version
68  directories are only updated if they do not already exist.
69
70COPYRIGHT
71  This program is part of the FCM system.
72  (C) Crown copyright Met Office. All rights reserved.
73  For further details please refer to the file COPYRIGHT.txt
74  which you should have received as part of this distribution.
75EOF
76
77# Options
78# ------------------------------------------------------------------------------
79my ($dest, $full, $help, $url);
80GetOptions (
81  'dest|d=s' => \$dest,
82  'full|f'   => \$full,
83  'help'     => \$help,
84  'url|u=s'  => \$url,
85);
86
87if ($help) {
88  print $usage;
89  exit;
90}
91
92$dest = cwd () unless $dest;
93
94die 'An URL must be specified with the --url option, abort' unless $url;
95
96# Arguments
97# ------------------------------------------------------------------------------
98if (@ARGV) {
99  die 'Cannot read: ', $ARGV[0], ', abort' unless -f $ARGV[0] and -r $ARGV[0];
100}
101
102# Get configuration settings
103# ------------------------------------------------------------------------------
104my $config = Fcm::Config->new ();
105$config->get_config ();
106
107# Expand URL keyword
108$url = &expand_url_keyword (URL => $url);
109
110# ------------------------------------------------------------------------------
111# SYNOPSIS
112#   $cfg = &main::cfg ();
113#
114# DESCRIPTION
115#   Return the $config variable.
116# ------------------------------------------------------------------------------
117
118sub cfg {
119  return $config;
120}
121
122# ------------------------------------------------------------------------------
123
124MAIN: {
125  my $date = localtime;
126  print $this, ': started on ', $date, "\n";
127
128  my %dirs;
129
130  # Read input (file) for a list directories and update conditions
131  while (<>) {
132    chomp;
133
134    # Ignore empty and comment lines
135    next if /^\s*(?:#|$)/;
136
137    # Each line must contain a relative path, and optionally a list of
138    # space delimited conditions
139    my @words = split /\s+/;
140    my $dir   = shift @words;
141
142    # Check that the conditions are valid
143    my @conditions;
144    for my $word (@words) {
145      if ($word =~ /^([<>]=?|[!=]=)(.+)$/i) {
146        # Condition must be a conditional operator followed by a revision
147        my ($operator, $rev) = ($1, $2);
148        $rev = &expand_rev_keyword (REV => $rev, URL => $url, HEAD => 1);
149        push @conditions, $operator . $rev;
150
151      } else {
152        print STDERR 'Warning: ignore unknown syntax for update condition: ',
153                     $word, "\n";
154      }
155    }
156
157    # Add directory and its conditions to a hash
158    if ($dir =~ s#/\*$##) { # Directory finishes with wildcard
159
160      # Run "svn ls" in recursive mode
161      my $dirurl  = join ('/', ($url, $dir));
162      my @files   = &run_command ([qw/svn ls -R/, $dirurl], METHOD => 'qx');
163
164      # Find directories containing regular files
165      while (my $file = shift @files) {
166        # Skip directories
167        next if $file =~ m#/$#;
168
169        # Get "dirname" of regular file and add to hash
170        my $subdir = join ('/', ($dir, dirname ($file)));
171        $dirs{$subdir} = \@conditions;
172      }
173
174    } else {
175      $dirs{$dir} = \@conditions;
176    }
177
178  }
179
180  # Update each directory, if required
181  for my $dir (sort keys %dirs) {
182    # Use "svn log" to determine the revisions that need to be updated
183    my %allversions;
184    {
185      my $command = 'svn log -q ' . join ('/', ($url, $dir));
186      my @log     = &run_command (
187        [qw/svn log -q/, join ('/', ($url, $dir))], METHOD => 'qx',
188      );
189      @log        = grep /^r\d+/, @log;
190
191      # Assign a sequential "version" number to each sub-directory
192      my $version = scalar @log;
193      for (@log) {
194        m/^r(\d+)/;
195        $allversions{$1} = 'v' . $version--;
196      }
197    }
198    my %versions = %allversions;
199
200    # Extract only revisions matching the conditions
201    if (@{ $dirs{$dir} }) {
202      my @conditions = @{ $dirs{$dir} };
203
204      for my $condition (@conditions) {
205        for my $rev (keys %versions) {
206          delete $versions{$rev} unless eval ($rev . $condition);
207        }
208      }
209    }
210
211    # Destination directory
212    my $dirpath = File::Spec->catfile ($dest, $dir);
213
214    if (-d $dirpath) {
215      if ($full or not keys %versions) {
216        # Remove destination directory top, in full mode
217        # or if there are no matching revisions
218        &run_command ([qw/rm -rf/, $dirpath], PRINT => 1);
219
220      } else {
221        # Delete excluded revisions if they exist, in incremental mode
222        if (opendir DIR, $dirpath) {
223          while (my $rev = readdir 'DIR') {
224            next unless $rev =~ /^\d+$/;
225
226            if (not grep {$_ eq $rev} keys %versions) {
227              my @command = (qw/rm -rf/, File::Spec->catfile ($dirpath, $rev));
228              &run_command (\@command, PRINT => 1);
229
230              # Remove "version" symlink
231              my $verlink = File::Spec->catfile ($dirpath, $allversions{$rev});
232              unlink $verlink if -l $verlink;
233            }
234          }
235          closedir DIR;
236        }
237      }
238    }
239
240    # Create container directory of destination if it does not already exist
241    if (keys %versions and not -d $dirpath) {
242      print '-> mkdir -p ', $dirpath, "\n";
243      my $rc = mkpath $dirpath;
244      die 'mkdir -p ', $dirpath, ' failed' unless $rc;
245    }
246
247    # Update each version directory that needs updating
248    for my $rev (keys %versions) {
249      my $revpath = File::Spec->catfile ($dest, $dir, $rev);
250
251      # Create version directory if it does not exist
252      if (not -e $revpath) {
253        # Use "svn export" to create the version directory
254        my @command = (
255          qw/svn export -q -r/,
256          $rev,
257          join ('/', ($url, $dir)),
258          $revpath,
259        );
260
261        &run_command (\@command, PRINT => 1);
262
263        # Run GenScr_GenRule on any component directories
264        # This can be removed once old versions of the SCSUI are no longer used
265        if ($dir =~ m#(?:^|/)components/#) {
266          my @command = (
267            "GenScr_GenRule",
268            File::Spec->catfile ($revpath, join ('.', (basename ($dir), "rule")))
269          );
270
271          &run_command (\@command, PRINT => 1);
272        }
273      }
274
275      # Create "version" symlink if necessary
276      my $verlink = File::Spec->catfile ($dest, $dir, $versions{$rev});
277      symlink $rev, $verlink unless -l $verlink;
278    }
279
280    # Symbolic link to the "latest" version directory
281    my $headlink = File::Spec->catfile ($dest, $dir, 'latest');
282    my $headrev  = 0;
283    for my $rev (keys %versions) {
284      $headrev = $rev if $rev > $headrev;
285    }
286
287    if (-l $headlink) {
288      # Remove old symbolic link if there is no revision to update or if it
289      # does not point to the correct version directory
290      my $org = readlink $headlink;
291      unlink $headlink if (! $headrev or $org ne $headrev);
292    }
293
294    # (Re-)create the "latest" symbolic link, if necessary
295    symlink $headrev, $headlink if ($headrev and not -l $headlink);
296  }
297
298  $date = localtime;
299  print $this, ': finished normally on ', $date, "\n";
300}
301
302__END__
Note: See TracBrowser for help on using the repository browser.