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.
SrcDirLayer.pm in branches/UKMO/2015_CO6_CO5_shelfdiagnostic/NEMOGCM/EXTERNAL/fcm/lib/Fcm – NEMO

source: branches/UKMO/2015_CO6_CO5_shelfdiagnostic/NEMOGCM/EXTERNAL/fcm/lib/Fcm/SrcDirLayer.pm @ 5422

Last change on this file since 5422 was 5422, checked in by deazer, 9 years ago

Pre removal of svn keywords

File size: 7.3 KB
Line 
1# ------------------------------------------------------------------------------
2# NAME
3#   Fcm::SrcDirLayer
4#
5# DESCRIPTION
6#   This class contains methods to manipulate the extract of a source
7#   directory from a branch of a (Subversion) repository.
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# ------------------------------------------------------------------------------
14use warnings;
15use strict;
16
17package Fcm::SrcDirLayer;
18use base qw{Fcm::Base};
19
20use Fcm::Util      qw{run_command e_report w_report};
21use File::Basename qw{dirname};
22use File::Path     qw{mkpath};
23use File::Spec;
24
25# List of property methods for this class
26my @scalar_properties = (
27  'cachedir',  # cache directory for this directory branch
28  'commit',    # revision at which the source directory was changed
29  'extracted', # is this branch already extracted?
30  'files',     # list of source files in this directory branch
31  'location',  # location of the source directory in the branch
32  'name',      # sub-package name of the source directory
33  'package',   # top level package name of which the current repository belongs
34  'reposroot', # repository root URL
35  'revision',  # revision of the repository branch
36  'tag',       # package/revision tag of the current repository branch
37  'type',      # type of the repository branch ("svn" or "user")
38);
39
40my %ERR_MESS_OF = (
41    CACHE_WRITE => '%s: cannot write to cache',
42    SYMLINK     => '%s/%s: ignore symbolic link',
43    VC_TYPE     => '%s: repository type not supported',
44);
45
46# ------------------------------------------------------------------------------
47# SYNOPSIS
48#   $obj = Fcm::SrcDirLayer->new (%args);
49#
50# DESCRIPTION
51#   This method constructs a new instance of the Fcm::SrcDirLayer class. See
52#   above for allowed list of properties. (KEYS should be in uppercase.)
53# ------------------------------------------------------------------------------
54
55sub new {
56  my $this  = shift;
57  my %args  = @_;
58  my $class = ref $this || $this;
59
60  my $self = Fcm::Base->new (%args);
61
62  for (@scalar_properties) {
63    $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef;
64  }
65
66  bless $self, $class;
67  return $self;
68}
69
70# ------------------------------------------------------------------------------
71# SYNOPSIS
72#   $value = $obj->X;
73#   $obj->X ($value);
74#
75# DESCRIPTION
76#   Details of these properties are explained in @scalar_properties.
77# ------------------------------------------------------------------------------
78
79for my $name (@scalar_properties) {
80  no strict 'refs';
81
82  *$name = sub {
83    my $self = shift;
84
85    # Argument specified, set property to specified argument
86    if (@_) {
87      $self->{$name} = $_[0];
88    }
89
90    # Default value for property
91    if (not defined $self->{$name}) {
92      if ($name eq 'files') {
93        # Reference to an array
94        $self->{$name} = [];
95      }
96    }
97
98    return $self->{$name};
99  }
100}
101
102# Handles error/warning events.
103sub _err {
104    my ($key, $args_ref, $warn_only) = @_;
105    my $reporter = $warn_only ? \&w_report : \&e_report;
106    $args_ref ||= [];
107    $reporter->(sprintf($ERR_MESS_OF{$key} . ".\n", @{$args_ref}));
108}
109
110# ------------------------------------------------------------------------------
111# SYNOPSIS
112#   $dir = $obj->localdir;
113#
114# DESCRIPTION
115#   This method returns the user or cache directory for the current revision
116#   of the repository branch.
117# ------------------------------------------------------------------------------
118
119sub localdir {
120  my $self = shift;
121
122  return $self->user ? $self->location : $self->cachedir;
123}
124
125# ------------------------------------------------------------------------------
126# SYNOPSIS
127#   $user = $obj->user;
128#
129# DESCRIPTION
130#   This method returns the string "user" if the current source directory
131#   branch is a local directory. Otherwise, it returns "undef".
132# ------------------------------------------------------------------------------
133
134sub user {
135  my $self = shift;
136
137  return $self->type eq 'user' ? 'user' : undef;
138}
139
140# ------------------------------------------------------------------------------
141# SYNOPSIS
142#   $rev = $obj->get_commit;
143#
144# DESCRIPTION
145#   If the current repository type is "svn", this method attempts to obtain
146#   the revision in which the branch is last committed. On a successful
147#   operation, it returns this revision number. Otherwise, it returns
148#   "undef".
149# ------------------------------------------------------------------------------
150
151sub get_commit {
152  my $self = shift;
153
154  if ($self->type eq 'svn') {
155    # Execute the "svn info" command
156    my @lines   = &run_command (
157      [qw/svn info -r/, $self->revision, $self->location . '@' . $self->revision],
158      METHOD => 'qx', TIME => $self->config->verbose > 2,
159    );
160
161    my $rev;
162    for (@lines) {
163      if (/^Last\s+Changed\s+Rev\s*:\s*(\d+)/i) {
164        $rev = $1;
165        last;
166      }
167    }
168
169    # Commit revision of this source directory
170    $self->commit ($rev);
171
172    return $self->commit;
173
174  } elsif ($self->type eq 'user') {
175    return;
176
177  } else {
178    _err('VC_TYPE', [$self->type()]);
179  }
180}
181
182# ------------------------------------------------------------------------------
183# SYNOPSIS
184#   $rc = $obj->update_cache;
185#
186# DESCRIPTION
187#   If the current repository type is "svn", this method attempts to extract
188#   the current revision source directory from the current branch from the
189#   repository, sending the output to the cache directory. It returns true on
190#   a successful operation, or false if the repository is not of type "svn".
191# ------------------------------------------------------------------------------
192
193sub update_cache {
194  my $self = shift;
195
196  return unless $self->cachedir;
197
198  # Create cache extract destination, if necessary
199  my $dirname = dirname $self->cachedir;
200  mkpath($dirname);
201
202  if (!-w $dirname) {
203    _err('CACHE_WRITE', [$dirname]);
204  }
205 
206  if ($self->type eq 'svn') {
207    # Set up the extract command, "svn export --force -q -N"
208    my @command = (
209      qw/svn export --force -q -N/,
210      $self->location . '@' . $self->revision,
211      $self->cachedir,
212    );
213
214    &run_command (\@command, TIME => $self->config->verbose > 2);
215
216  } elsif ($self->type eq 'user') {
217    return;
218
219  } else {
220    _err('VC_TYPE', [$self->type()]);
221  }
222
223  return 1;
224}
225
226# ------------------------------------------------------------------------------
227# SYNOPSIS
228#   @files = $obj->get_files();
229#
230# DESCRIPTION
231#   This method returns a list of file base names in the (cache of) this source
232#   directory in the current branch.
233# ------------------------------------------------------------------------------
234
235sub get_files {
236  my ($self) = @_;
237  opendir(my $dir, $self->localdir())
238    || die($self->localdir(), ': cannot read directory');
239  my @base_names = ();
240  BASE_NAME:
241  while (my $base_name = readdir($dir)) {
242    if ($base_name =~ qr{\A\.}xms || $base_name =~ qr{~\z}xms) {
243        next BASE_NAME;
244    }
245    my $path = File::Spec->catfile($self->localdir(), $base_name);
246    if (-d $path) {
247        next BASE_NAME;
248    }
249    if (-l $path) {
250        _err('SYMLINK', [$self->location(), $base_name], 1);
251        next BASE_NAME;
252    }
253    push(@base_names, $base_name);
254  }
255  closedir($dir);
256  $self->files(\@base_names);
257  return @base_names;
258}
259
260# ------------------------------------------------------------------------------
261
2621;
263
264__END__
Note: See TracBrowser for help on using the repository browser.