source: branches/2015/dev_r5021_UKMO1_CICE_coupling/NEMOGCM/EXTERNAL/fcm/lib/Fcm/ReposBranch.pm @ 5445

Last change on this file since 5445 was 5445, checked in by davestorkey, 5 years ago

Clear SVN keywords from 2015/dev_r5021_UKMO1_CICE_coupling branch.

File size: 15.3 KB
Line 
1# ------------------------------------------------------------------------------
2# NAME
3#   Fcm::ReposBranch
4#
5# DESCRIPTION
6#   This class contains methods for gathering information for a repository
7#   branch. It currently supports Subversion repository and local user
8#   directory.
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
16use warnings;
17use strict;
18
19package Fcm::ReposBranch;
20use base qw{Fcm::Base};
21
22use Fcm::CfgLine;
23use Fcm::Keyword;
24use Fcm::Util      qw{expand_tilde is_url run_command w_report};
25use File::Basename qw{dirname};
26use File::Find     qw{find};
27use File::Spec;
28
29# List of scalar property methods for this class
30my @scalar_properties = (
31  'package',  # package name of which this repository belongs
32  'repos',    # repository branch root URL/path
33  'revision', # the revision of this branch
34  'tag',      # "tag" name of this branch of the repository
35  'type',     # repository type
36);
37
38# List of hash property methods for this class
39my @hash_properties = (
40  'dirs',    # list of non-recursive directories in this branch
41  'expdirs', # list of recursive directories in this branch
42);
43
44# ------------------------------------------------------------------------------
45# SYNOPSIS
46#   $obj = Fcm::ReposBranch->new (%args);
47#
48# DESCRIPTION
49#   This method constructs a new instance of the Fcm::ReposBranch class. See
50#   @scalar_properties above for allowed list of properties in the constructor.
51#   (KEYS should be in uppercase.)
52# ------------------------------------------------------------------------------
53
54sub new {
55  my $this  = shift;
56  my %args  = @_;
57  my $class = ref $this || $this;
58
59  my $self = Fcm::Base->new (%args);
60
61  for (@scalar_properties) {
62    $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef;
63  }
64
65  $self->{$_} = {} for (@hash_properties);
66
67  bless $self, $class;
68  return $self;
69}
70
71# ------------------------------------------------------------------------------
72# SYNOPSIS
73#   $value = $obj->X;
74#   $obj->X ($value);
75#
76# DESCRIPTION
77#   Details of these properties are explained in @scalar_properties.
78# ------------------------------------------------------------------------------
79
80for my $name (@scalar_properties) {
81  no strict 'refs';
82
83  *$name = sub {
84    my $self = shift;
85
86    # Argument specified, set property to specified argument
87    if (@_) {
88      $self->{$name} = $_[0];
89    }
90
91    return $self->{$name};
92  }
93}
94
95# ------------------------------------------------------------------------------
96# SYNOPSIS
97#   %hash = %{ $obj->X () };
98#   $obj->X (\%hash);
99#
100#   $value = $obj->X ($index);
101#   $obj->X ($index, $value);
102#
103# DESCRIPTION
104#   Details of these properties are explained in @hash_properties.
105#
106#   If no argument is set, this method returns a hash containing a list of
107#   objects. If an argument is set and it is a reference to a hash, the objects
108#   are replaced by the the specified hash.
109#
110#   If a scalar argument is specified, this method returns a reference to an
111#   object, if the indexed object exists or undef if the indexed object does
112#   not exist. If a second argument is set, the $index element of the hash will
113#   be set to the value of the argument.
114# ------------------------------------------------------------------------------
115
116for my $name (@hash_properties) {
117  no strict 'refs';
118
119  *$name = sub {
120    my ($self, $arg1, $arg2) = @_;
121
122    # Ensure property is defined as a reference to a hash
123    $self->{$name} = {} if not defined ($self->{$name});
124
125    # Argument 1 can be a reference to a hash or a scalar index
126    my ($index, %hash);
127
128    if (defined $arg1) {
129      if (ref ($arg1) eq 'HASH') {
130        %hash = %$arg1;
131
132      } else {
133        $index = $arg1;
134      }
135    }
136
137    if (defined $index) {
138      # A scalar index is defined, set and/or return the value of an element
139      $self->{$name}{$index} = $arg2 if defined $arg2;
140
141      return (
142        exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
143      );
144
145    } else {
146      # A scalar index is not defined, set and/or return the hash
147      $self->{$name} = \%hash if defined $arg1;
148      return $self->{$name};
149    }
150  }
151}
152
153# ------------------------------------------------------------------------------
154# SYNOPSIS
155#   $rc = $obj->expand_revision;
156#
157# DESCRIPTION
158#   This method expands the revision keywords of the current branch to a
159#   revision number. It returns true on success.
160# ------------------------------------------------------------------------------
161
162sub expand_revision {
163  my $self = shift;
164
165  my $rc = 1;
166  if ($self->type eq 'svn') {
167    # Expand revision keyword
168    my $rev = (Fcm::Keyword::expand($self->repos(), $self->revision()))[1];
169
170    # Get last changed revision of the specified revision
171    my $info_ref = $self->_svn_info($self->repos(), $rev);
172    if (!defined($info_ref->{'Revision'})) {
173      my $url = $self->repos() . ($rev ? '@' . $rev : q{});
174      w_report("ERROR: $url: not a valid URL\n");
175      return 0;
176    }
177    my $lc_rev = $info_ref->{'Last Changed Rev'};
178    $rev       = $info_ref->{'Revision'};
179
180    # Print info if specified revision is not the last commit revision
181    if (uc($self->revision()) ne 'HEAD' && $lc_rev != $rev) {
182      my $message = $self->repos . '@' . $rev . ': last changed at [' .
183                    $lc_rev . '].';
184      if ($self->setting ('EXT_REVMATCH') and uc ($self->revision) ne 'HEAD') {
185        w_report "ERROR: specified and last changed revisions differ:\n",
186                 '       ', $message, "\n";
187        $rc = 0;
188
189      } else {
190        print 'INFO: ', $message, "\n";
191      }
192    }
193
194    if ($self->verbose > 1 and uc ($self->revision) ne 'HEAD') {
195      # See if there is a later change of the branch at the HEAD
196      my $head_lc_rev = $self->_svn_info($self->repos())->{'Last Changed Rev'};
197
198      if (defined($head_lc_rev) && $head_lc_rev != $lc_rev) {
199        # Ensure that this is the same branch by checking its history
200        my @lines = &run_command (
201          [qw/svn log -q --incremental -r/, $lc_rev, $self->repos . '@HEAD'],
202          METHOD => 'qx', TIME => $self->verbose > 2,
203        );
204
205        print 'INFO: ', $self->repos, '@', $rev,
206              ': newest commit at [', $head_lc_rev, '].', "\n"
207          if @lines;
208      }
209    }
210
211    $self->revision ($rev) if $rev ne $self->revision;
212
213  } elsif ($self->type eq 'user') {
214    1; # Do nothing
215
216  } else {
217    w_report 'ERROR: ', $self->repos, ': repository type "', $self->type,
218             '" not supported.';
219    $rc = 0;
220  }
221
222  return $rc;
223}
224
225# ------------------------------------------------------------------------------
226# SYNOPSIS
227#   $rc = $obj->expand_path;
228#
229# DESCRIPTION
230#   This method expands the relative path names of sub-directories to full
231#   path names. It returns true on success.
232# ------------------------------------------------------------------------------
233
234sub expand_path {
235  my $self = shift;
236
237  my $rc = 1;
238  if ($self->type eq 'svn') {
239    # SVN repository
240    # Do nothing unless there is a declared repository for this branch
241    return unless $self->repos;
242
243    # Remove trailing /
244    my $repos = $self->repos;
245    $self->repos ($repos) if $repos =~ s#/+$##;
246
247    # Consider all declared (expandable) sub-directories
248    for my $name (qw/dirs expdirs/) {
249      for my $dir (keys %{ $self->$name }) {
250        # Do nothing if declared sub-directory is quoted as a full URL
251        next if &is_url ($self->$name ($dir));
252
253        # Expand sub-directory to full URL
254        $self->$name ($dir, $self->repos . (
255          $self->$name ($dir) ? ('/' . $self->$name ($dir)) : ''
256        ));
257      }
258    }
259    # Note: "catfile" cannot be used in the above statement because it has
260    #       the tendency of removing a slash from double slashes.
261
262  } elsif ($self->type eq 'user') {
263    # Local user directories
264
265    # Expand leading ~ for all declared (expandable) sub-directories
266    for my $name (qw/dirs expdirs/) {
267      for my $dir (keys %{ $self->$name }) {
268        $self->$name ($dir, expand_tilde $self->$name ($dir));
269      }
270    }
271
272    # A top directory for the source is declared
273    if ($self->repos) {
274      # Expand leading ~ for the top directory
275      $self->repos (expand_tilde $self->repos);
276
277      # Get the root directory of the file system
278      my $rootdir = File::Spec->rootdir ();
279
280      # Expand top directory to absolute path, if necessary
281      $self->repos (File::Spec->rel2abs ($self->repos))
282        if $self->repos !~ m/^$rootdir/;
283
284      # Remove trailing /
285      my $repos = $self->repos;
286      $self->repos ($repos) if $repos =~ s#/+$##;
287
288      # Consider all declared (expandable) sub-directories
289      for my $name (qw/dirs expdirs/) {
290        for my $dir (keys %{ $self->$name }) {
291          # Do nothing if declared sub-directory is quoted as a full path
292          next if $self->$name ($dir) =~ m#^$rootdir#;
293
294          # Expand sub-directory to full path
295          $self->$name (
296            $dir, $self->$name ($dir)
297                  ? File::Spec->catfile ($self->repos, $self->$name ($dir))
298                  : $self->repos
299          );
300        }
301      }
302    }
303
304  } else {
305    w_report 'ERROR: ', $self->repos, ': repository type "', $self->type,
306             '" not supported.';
307    $rc = 0;
308  }
309
310  return $rc;
311}
312
313# ------------------------------------------------------------------------------
314# SYNOPSIS
315#   $rc = $obj->expand_all();
316#
317# DESCRIPTION
318#   This method searches the expandable source directories recursively for
319#   source directories containing regular files. The namespaces and the locators
320#   of these sub-directories are then added to the source directory hash table.
321#   Returns true on success.
322# ------------------------------------------------------------------------------
323
324sub expand_all {
325  my ($self) = @_;
326  my %finder_of = (
327    user => sub {
328      my ($root_locator) = @_;
329      my %ns_of;
330      my $wanted = sub {
331        my $base_name = $_;
332        my $path = $File::Find::name;
333        if (-f $path && -r $path && !-l $path) {
334          my $dir_path      = dirname($path);
335          my $rel_dir_path  = File::Spec->abs2rel($dir_path, $root_locator);
336          if (!exists($ns_of{$dir_path})) {
337            $ns_of{$dir_path} = [File::Spec->splitdir($rel_dir_path)];
338          }
339        }
340      };
341      find($wanted, $root_locator);
342      return \%ns_of;
343    },
344    svn  => sub {
345      my ($root_locator) = @_;
346      my $runner = sub {
347        map {chomp($_); $_} run_command(
348          ['svn', @_,  '-R', join('@', $root_locator, $self->revision())],
349          METHOD => 'qx', TIME => $self->config()->verbose() > 2,
350        );
351      };
352      # FIXME: check for symlink switched off due to "svn pg" being very slow
353      #my %symlink_in
354      #  = map {($_ =~ qr{\A(.+)\s-\s(\*)\z}xms)} ($runner->(qw{pg svn:special}));
355      #my @locators
356      #  = grep {$_ !~ qr{/\z}xms && !$symlink_in{$_}} ($runner->('ls'));
357      my @locators = grep {$_ !~ qr{/\z}xms} ($runner->('ls'));
358      my %ns_of;
359      for my $locator (@locators) {
360        my ($rel_dir_locator) = $locator =~ qr{\A(.*)/[^/]+\z}xms; # dirname
361        $rel_dir_locator ||= q{};
362        my $dir_locator = join(q{/}, $root_locator, $rel_dir_locator);
363        if (!exists($ns_of{$dir_locator})) {
364          $ns_of{$dir_locator} = [split(q{/}, $rel_dir_locator)];
365        }
366      }
367      return \%ns_of;
368    },
369  );
370
371  if (!defined($finder_of{$self->type()})) {
372    w_report(sprintf(
373        qq{ERROR: %s: resource type "%s" not supported},
374        $self->repos(),
375        $self->type(),
376    ));
377    return;
378  }
379  while (my ($root_ns, $root_locator) = each(%{$self->expdirs()})) {
380    my @root_ns_list = split(qr{$Fcm::Config::DELIMITER}xms, $root_ns);
381    my $ns_hash_ref = $finder_of{$self->type()}->($root_locator);
382    while (my ($dir_path, $ns_list_ref) = each(%{$ns_hash_ref})) {
383      if (!grep {$_ =~ qr{\A\.}xms || $_ =~ qr{~\z}xms} @{$ns_list_ref}) {
384        my $ns = join($Fcm::Config::DELIMITER, @root_ns_list, @{$ns_list_ref});
385        $self->dirs($ns, $dir_path);
386      }
387    }
388  }
389  return 1;
390}
391
392# ------------------------------------------------------------------------------
393# SYNOPSIS
394#   $n = $obj->add_base_dirs ($base);
395#
396# DESCRIPTION
397#   Add a list of source directories to the current branch based on the set
398#   provided by $base, which must be a reference to a Fcm::ReposBranch
399#   instance. It returns the total number of used sub-directories in the
400#   current repositories.
401# ------------------------------------------------------------------------------
402
403sub add_base_dirs {
404  my $self = shift;
405  my $base = shift;
406
407  my %base_dirs = %{ $base->dirs };
408
409  for my $key (keys %base_dirs) {
410    # Remove repository root from base directories
411    if ($base_dirs{$key} eq $base->repos) {
412      $base_dirs{$key} = '';
413
414    } else {
415      $base_dirs{$key} = substr $base_dirs{$key}, length ($base->repos) + 1;
416    }
417
418    # Append base directories to current repository root
419    $self->dirs ($key, $base_dirs{$key});
420  }
421
422  # Expand relative path names of sub-directories
423  $self->expand_path;
424
425  return scalar keys %{ $self->dirs };
426}
427
428# ------------------------------------------------------------------------------
429# SYNOPSIS
430#   @cfglines = $obj->to_cfglines ();
431#
432# DESCRIPTION
433#   This method returns a list of configuration lines for the current branch.
434# ------------------------------------------------------------------------------
435
436sub to_cfglines {
437  my ($self) = @_;
438  my @return = ();
439
440  my $suffix = $self->package . $Fcm::Config::DELIMITER . $self->tag;
441  push @return, Fcm::CfgLine->new (
442    label => $self->cfglabel ('REPOS') . $Fcm::Config::DELIMITER . $suffix,
443    value => $self->repos,
444  ) if $self->repos;
445
446  push @return, Fcm::CfgLine->new (
447    label => $self->cfglabel ('REVISION') . $Fcm::Config::DELIMITER . $suffix,
448    value => $self->revision,
449  ) if $self->revision;
450
451  for my $key (sort keys %{ $self->dirs }) {
452    my $value = $self->dirs ($key);
453
454    # Use relative path where possible
455    if ($self->repos) {
456      if ($value eq $self->repos) {
457        $value = '';
458
459      } elsif (index ($value, $self->repos) == 0) {
460        $value = substr ($value, length ($self->repos) + 1);
461      }
462    }
463
464    # Use top package name where possible
465    my $dsuffix = $key . $Fcm::Config::DELIMITER . $self->tag;
466    $dsuffix = $suffix if $value ne $self->dirs ($key) and $key eq join (
467      $Fcm::Config::DELIMITER, $self->package, File::Spec->splitdir ($value)
468    );
469
470    push @return, Fcm::CfgLine->new (
471      label => $self->cfglabel ('DIRS') . $Fcm::Config::DELIMITER . $dsuffix,
472      value => $value,
473    );
474  }
475
476  push @return, Fcm::CfgLine->new ();
477
478  return @return;
479}
480
481# ------------------------------------------------------------------------------
482# SYNOPSIS
483#   my $hash_ref = $self->_svn_info($url[, $rev]);
484#
485# DESCRIPTION
486#   Executes "svn info" and returns each field in a hash.
487# ------------------------------------------------------------------------------
488sub _svn_info {
489  my ($self, $url, $rev) = @_;
490  return {
491    map {
492      chomp();
493      my ($key, $value) = split(qr{\s*:\s*}xms, $_, 2);
494      $key ? ($key, $value) : ();
495    } run_command(
496      [qw{svn info}, ($rev ? ('-r', $rev, join('@', $url, $rev)) : $url)], 
497      DEVNULL => 1, METHOD => 'qx', TIME => $self->verbose() > 2,
498    )
499  };
500}
501
502# ------------------------------------------------------------------------------
503
5041;
505
506__END__
Note: See TracBrowser for help on using the repository browser.