source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM1/SrcDirLayer.pm @ 5407

Last change on this file since 5407 was 5129, checked in by abarral, 5 months ago

Re-add removed by mistake fcm

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