source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM1/ReposBranch.pm @ 5134

Last change on this file since 5134 was 5129, checked in by abarral, 19 months ago

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