source: LMDZ5/trunk/tools/fcm/lib/Fcm/SrcDirLayer.pm @ 3260

Last change on this file since 3260 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: 13.2 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   Fcm::SrcDirLayer
5#
6# DESCRIPTION
7#   This class contains methods to manipulate the extract of a source
8#   directory from a branch of a (Subversion) repository.
9#
10# COPYRIGHT
11#   (C) Crown copyright Met Office. All rights reserved.
12#   For further details please refer to the file COPYRIGHT.txt
13#   which you should have received as part of this distribution.
14# ------------------------------------------------------------------------------
15
16package Fcm::SrcDirLayer;
17
18# Standard pragma
19use warnings;
20use strict;
21
22# Standard modules
23use Carp;
24use File::Spec;
25use File::Spec::Functions;
26use File::Basename;
27use File::Path;
28use File::Compare;
29
30# FCM component modules
31use Fcm::Util;
32use Fcm::Timer;
33
34# ------------------------------------------------------------------------------
35# SYNOPSIS
36#   $layer = Fcm::SrcDirLayer->new (
37#     CONFIG    => $config,
38#     NAME      => $dir,
39#     PACKAGE   => $package,
40#     TAG       => $tag,
41#     LOCATION  => $loc,
42#     REPOSROOT => $repos,
43#     VERSION   => $ver,
44#     TYPE      => $type,
45#     COMMIT    => $com,
46#     EXTRACTED => $ext,
47#     CACHEDIR  => $cac,
48#   );
49#
50# DESCRIPTION
51#   This method constructs a new instance of the Fcm::SrcDirLayer class.
52#
53# ARGUMENTS
54#   CONFIG    - reference to a Fcm::Config instance
55#   NAME      - sub-package name of the source directory
56#   PACKAGE   - top level package name of which the current repository belongs
57#   TAG       - package/revision tag of the current repository branch
58#   LOCATION  - location of the source directory in the branch
59#   REPOSROOT - repository root URL
60#   VERSION   - revision of the repository branch
61#   TYPE      - type of the repository branch ("svn" or "user")
62#   COMMIT    - revision at which the source directory was changed
63#   EXTRACTED - is this branch already extracted?
64#   CACHEDIR  - cache directory for this directory branch
65# ------------------------------------------------------------------------------
66
67sub new {
68  my $this  = shift;
69  my %args  = @_;
70  my $class = ref $this || $this;
71
72  my $self = {
73    CONFIG    => (exists $args{CONFIG}    ? $args{CONFIG}    : &main::cfg),
74    NAME      => (exists $args{NAME}      ? $args{NAME}      : undef),
75    PACKAGE   => (exists $args{PACKAGE}   ? $args{PACKAGE}   : undef),
76    TAG       => (exists $args{TAG}       ? $args{TAG}       : undef),
77    LOCATION  => (exists $args{LOCATION}  ? $args{LOCATION}  : undef),
78    REPOSROOT => (exists $args{REPOSROOT} ? $args{REPOSROOT} : undef),
79    VERSION   => (exists $args{VERSION}   ? $args{VERSION}   : undef),
80    TYPE      => (exists $args{TYPE}      ? $args{TYPE}      : undef),
81    COMMIT    => (exists $args{COMMIT}    ? $args{COMMIT}    : undef),
82    EXTRACTED => (exists $args{EXTRACTED} ? $args{EXTRACTED} : undef),
83    CACHEDIR  => (exists $args{CACHEDIR}  ? $args{CACHEDIR}  : undef),
84
85    # List of source files in this directory branch
86    FILES     => [],
87  };
88
89  bless $self, $class;
90  return $self;
91}
92
93# ------------------------------------------------------------------------------
94# SYNOPSIS
95#   $config = $layer->config;
96#
97# DESCRIPTION
98#   This method returns a reference to the Fcm::Config instance.
99# ------------------------------------------------------------------------------
100
101sub config {
102  my $self = shift;
103
104  return $self->{CONFIG};
105}
106
107# ------------------------------------------------------------------------------
108# SYNOPSIS
109#   $name = $layer->name;
110#   $layer->name ($name);
111#
112# DESCRIPTION
113#   This method returns the sub-package name of the current source directory.
114#   If an argument is specified, the sub-package name is set to the value of
115#   the argument.
116# ------------------------------------------------------------------------------
117
118sub name {
119  my $self = shift;
120
121  if (@_) {
122    $self->{NAME} = shift;
123  }
124
125  return $self->{NAME};
126}
127
128# ------------------------------------------------------------------------------
129# SYNOPSIS
130#   $package = $layer->package;
131#   $layer->package ($package);
132#
133# DESCRIPTION
134#   This method returns the top level package name in which the current source
135#   directory belongs. If an argument is specified, the package name is set to
136#   the value of the argument.
137# ------------------------------------------------------------------------------
138
139sub package {
140  my $self = shift;
141
142  if (@_) {
143    $self->{PACKAGE} = shift;
144  }
145
146  return $self->{PACKAGE};
147}
148
149# ------------------------------------------------------------------------------
150# SYNOPSIS
151#   $tag = $layer->tag;
152#   $layer->tag ($tag);
153#
154# DESCRIPTION
155#   This method returns the branch/revision tag of the current repository
156#   branch. If an argument is specified, the tag is set to the value of the
157#   argument.
158# ------------------------------------------------------------------------------
159
160sub tag {
161  my $self = shift;
162
163  if (@_) {
164    $self->{TAG} = shift;
165  }
166
167  return $self->{TAG};
168}
169
170# ------------------------------------------------------------------------------
171# SYNOPSIS
172#   $location = $layer->location;
173#   $layer->location ($location);
174#
175# DESCRIPTION
176#   This method returns the URL/location of the source directory in the
177#   branch. If an argument is specified, the location is set to the value of
178#   the argument.
179# ------------------------------------------------------------------------------
180
181sub location {
182  my $self = shift;
183
184  if (@_) {
185    $self->{LOCATION} = shift;
186  }
187
188  return $self->{LOCATION};
189}
190
191# ------------------------------------------------------------------------------
192# SYNOPSIS
193#   $reposroot = $layer->reposroot;
194#   $layer->reposroot ($reposroot);
195#
196# DESCRIPTION
197#   This method returns the URL/location of the repository root of this
198#   branch. If an argument is specified, the location is set to the value of
199#   the argument.
200# ------------------------------------------------------------------------------
201
202sub reposroot {
203  my $self = shift;
204
205  if (@_) {
206    $self->{REPOSROOT} = shift;
207  }
208
209  return $self->{REPOSROOT};
210}
211
212# ------------------------------------------------------------------------------
213# SYNOPSIS
214#   $version = $layer->version;
215#   $layer->version ($version);
216#
217# DESCRIPTION
218#   This method returns the revision number of this branch. If an argument is
219#   specified, the revision number is set to the value of the argument.
220# ------------------------------------------------------------------------------
221
222sub version {
223  my $self = shift;
224
225  if (@_) {
226    $self->{VERSION} = shift;
227  }
228
229  return $self->{VERSION};
230}
231
232# ------------------------------------------------------------------------------
233# SYNOPSIS
234#   $type = $layer->type;
235#   $layer->type ($type);
236#
237# DESCRIPTION
238#   This method returns the repository type ("svn" or "user"). If an argument is
239#   specified, the type is set to the value of the argument.
240# ------------------------------------------------------------------------------
241
242sub type {
243  my $self = shift;
244
245  if (@_) {
246    $self->{TYPE} = shift;
247  }
248
249  return $self->{TYPE};
250}
251
252# ------------------------------------------------------------------------------
253# SYNOPSIS
254#   $version = $layer->commit;
255#   $layer->commit ($version);
256#
257# DESCRIPTION
258#   This method returns the last modified revision of the source directory in
259#   the branch. If an argument is specified, this revision is set to the value
260#   of the argument.
261# ------------------------------------------------------------------------------
262
263sub commit {
264  my $self = shift;
265
266  if (@_) {
267    $self->{COMMIT} = shift;
268  }
269
270  return $self->{COMMIT};
271}
272
273# ------------------------------------------------------------------------------
274# SYNOPSIS
275#   $extracted = $layer->extracted;
276#   $layer->extracted ($extracted);
277#
278# DESCRIPTION
279#   This method returns the "extracted flag" of the source directory branch
280#   If an argument is specified, the flag is set to the value of the argument.
281# ------------------------------------------------------------------------------
282
283sub extracted {
284  my $self = shift;
285
286  if (@_) {
287    $self->{EXTRACTED} = shift;
288  }
289
290  return $self->{EXTRACTED};
291}
292
293# ------------------------------------------------------------------------------
294# SYNOPSIS
295#   $dir = $layer->cachedir;
296#   $layer->cachedir ($dir);
297#
298# DESCRIPTION
299#   This method returns the cache directory of the source directory branch
300#   If an argument is specified, the cache directory is set to the value of
301#   the argument.
302# ------------------------------------------------------------------------------
303
304sub cachedir {
305  my $self = shift;
306
307  if (@_) {
308    my $dir = shift;
309    $self->{CACHEDIR} = $dir;
310  }
311
312  return $self->{CACHEDIR};
313}
314
315# ------------------------------------------------------------------------------
316# SYNOPSIS
317#   $dir = $layer->localdir;
318#
319# DESCRIPTION
320#   This method returns the user or cache directory for the current revision
321#   of the repository branch.
322# ------------------------------------------------------------------------------
323
324sub localdir {
325  my $self = shift;
326
327  return $self->user ? $self->{LOCATION} : $self->{CACHEDIR};
328}
329
330# ------------------------------------------------------------------------------
331# SYNOPSIS
332#   @files = $layer->files;
333#
334# DESCRIPTION
335#   This method returns a list of regular files in this directory branch.
336#   This method should only be called after a successful operation of the
337#   get_files method that will be described below.
338# ------------------------------------------------------------------------------
339
340sub files {
341  my $self = shift;
342
343  return @{ $self->{FILES} };
344}
345
346# ------------------------------------------------------------------------------
347# SYNOPSIS
348#   $user = $layer->user;
349#
350# DESCRIPTION
351#   This method returns the string "user" if the current source directory
352#   branch is a local directory. Otherwise, it returns "undef".
353# ------------------------------------------------------------------------------
354
355sub user {
356  my $self = shift;
357
358  return $self->{TYPE} eq 'user' ? 'user' : undef;
359}
360
361# ------------------------------------------------------------------------------
362# SYNOPSIS
363#   $version = $layer->get_commit;
364#
365# DESCRIPTION
366#   If the current repository type is "svn", this method attempts to obtain
367#   the revision in which the branch is last committed. On a successful
368#   operation, it returns this revision number. Otherwise, it returns
369#   "undef".
370# ------------------------------------------------------------------------------
371
372sub get_commit {
373  my $self = shift;
374
375  if ($self->type eq 'svn') {
376    # Execute the "svn info" command
377    my @lines   = &run_command (
378      [qw/svn info/, $self->{LOCATION} . '@' . $self->{VERSION}],
379      METHOD => 'qx', TIME => $self->config->verbose > 2,
380    );
381
382    my $rev;
383    for (@lines) {
384      if (/^Last\s+Changed\s+Rev\s*:\s*(\d+)/i) {
385        $rev = $1;
386        last;
387      }
388    }
389
390    # Commit version of this source directory
391    $self->{COMMIT} = $rev;
392
393    return $self->{COMMIT};
394
395  } elsif ($self->type eq 'user') {
396    return;
397
398  } else {
399    e_report 'Repository type "', $self->type, '" not supported.';
400  }
401}
402
403# ------------------------------------------------------------------------------
404# SYNOPSIS
405#   $rc = $layer->update_cache;
406#
407# DESCRIPTION
408#   If the current repository type is "svn", this method attempts to extract
409#   the current version source directory from the current branch from the
410#   repository, sending the output to the cache directory. It returns true on
411#   a successful operation, or false if the repository is not of type "svn".
412# ------------------------------------------------------------------------------
413
414sub update_cache {
415  my $self = shift;
416
417  return unless $self->{CACHEDIR};
418
419  # Create cache extract destination, if necessary
420  my $dirname = dirname $self->{CACHEDIR};
421  mkpath $dirname if not -d $dirname;
422
423  e_report $dirname, ': cannot write to cache, abort.'
424    unless -d $dirname and -w $dirname;
425 
426  if ($self->type eq 'svn') {
427    # Set up the extract command, "svn export --force -q -N"
428    my @command = (
429      qw/svn export --force -q -N/,
430      $self->{LOCATION} . '@' . $self->{VERSION},
431      $self->{CACHEDIR},
432    );
433
434    &run_command (\@command, TIME => $self->config->verbose > 2);
435
436  } elsif ($self->type eq 'user') {
437    return;
438
439  } else {
440    e_report 'Repository type "', $self->type, '" not supported.';
441  }
442
443  return 1;
444}
445
446# ------------------------------------------------------------------------------
447# SYNOPSIS
448#   @files = $layer->get_files;
449#
450# DESCRIPTION
451#   This method returns a list of files in the cache or local user directory
452#   of the current version of the source directory in the current branch.
453# ------------------------------------------------------------------------------
454
455sub get_files {
456  my $self = shift;
457
458  # Get a list of files in the cache (or local user) directory
459  my @files = ();
460
461  opendir (DIR, $self->localdir)
462    or die $self->localdir, ': cannot read directory';
463
464  while (my $file = readdir DIR) {
465    next if $file =~ /^\.\.?/;                   # ignore . and .. and hidden
466    next if $file =~ /~$/;                       # ignore emacs swap files
467    next if -d catfile ($self->localdir, $file); # ignore sub-directories
468    push @files, $file;
469  }
470  closedir DIR;
471
472  # Return the (base name) of the list of files
473  $self->{FILES} = \@files;
474  return @files;
475}
476
477# ------------------------------------------------------------------------------
478
4791;
480
481__END__
Note: See TracBrowser for help on using the repository browser.