source: OFFICIAL/FCM_V1.3/lib/Fcm/ReposBranch.pm

Last change on this file was 1, checked in by fcm, 15 years ago

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