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.
Extract.pm in vendors/lib/FCM1 – NEMO

source: vendors/lib/FCM1/Extract.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing
File size: 34.0 KB
Line 
1# ------------------------------------------------------------------------------
2# (C) British Crown Copyright 2006-17 Met Office.
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::Extract
21#
22# DESCRIPTION
23#   This is the top level class for the FCM extract system.
24#
25# ------------------------------------------------------------------------------
26
27package FCM1::Extract;
28@ISA = qw(FCM1::ConfigSystem);
29
30# Standard pragma
31use warnings;
32use strict;
33
34# Standard modules
35use File::Path;
36use File::Spec;
37
38# FCM component modules
39use FCM1::CfgFile;
40use FCM1::CfgLine;
41use FCM1::Config;
42use FCM1::ConfigSystem;
43use FCM1::Dest;
44use FCM1::ExtractFile;
45use FCM1::ExtractSrc;
46use FCM1::Keyword;
47use FCM1::ReposBranch;
48use FCM1::SrcDirLayer;
49use FCM1::Util;
50
51# List of scalar property methods for this class
52my @scalar_properties = (
53 'bdeclare', # list of build declarations
54 'branches', # list of repository branches
55 'conflict', # conflict mode
56 'rdest'   , # remote destination information
57);
58
59# List of hash property methods for this class
60my @hash_properties = (
61 'srcdirs' , # list of source directory extract info
62 'files',    # list of files processed key=pkgname, value=FCM1::ExtractFile
63);
64
65# ------------------------------------------------------------------------------
66# SYNOPSIS
67#   $obj = FCM1::Extract->new;
68#
69# DESCRIPTION
70#   This method constructs a new instance of the FCM1::Extract class.
71# ------------------------------------------------------------------------------
72
73sub new {
74  my $this  = shift;
75  my %args  = @_;
76  my $class = ref $this || $this;
77
78  my $self = FCM1::ConfigSystem->new (%args);
79
80  $self->{$_} = undef for (@scalar_properties);
81
82  $self->{$_} = {} for (@hash_properties);
83
84  bless $self, $class;
85
86  # List of sub-methods for parse_cfg
87  push @{ $self->cfg_methods }, (qw/rdest bld conflict project/);
88
89  # System type
90  $self->type ('ext');
91
92  return $self;
93}
94
95# ------------------------------------------------------------------------------
96# SYNOPSIS
97#   $value = $obj->X;
98#   $obj->X ($value);
99#
100# DESCRIPTION
101#   Details of these properties are explained in @scalar_properties.
102# ------------------------------------------------------------------------------
103
104for my $name (@scalar_properties) {
105  no strict 'refs';
106
107  *$name = sub {
108    my $self = shift;
109
110    # Argument specified, set property to specified argument
111    if (@_) {
112      $self->{$name} = $_[0];
113    }
114
115    # Default value for property
116    if (not defined $self->{$name}) {
117      if ($name eq 'bdeclare' or $name eq 'branches') {
118        # Reference to an array
119        $self->{$name} = [];
120
121      } elsif ($name eq 'rdest') {
122        # New extract destination local/remote
123        $self->{$name} = FCM1::Dest->new (DEST0 => $self->dest(), TYPE => 'ext');
124
125      } elsif ($name eq 'conflict') {
126        # Conflict mode, default to "merge"
127        $self->{$name} = 'merge';
128      }
129    }
130
131    return $self->{$name};
132  }
133}
134
135# ------------------------------------------------------------------------------
136# SYNOPSIS
137#   %hash = %{ $obj->X () };
138#   $obj->X (\%hash);
139#
140#   $value = $obj->X ($index);
141#   $obj->X ($index, $value);
142#
143# DESCRIPTION
144#   Details of these properties are explained in @hash_properties.
145#
146#   If no argument is set, this method returns a hash containing a list of
147#   objects. If an argument is set and it is a reference to a hash, the objects
148#   are replaced by the specified hash.
149#
150#   If a scalar argument is specified, this method returns a reference to an
151#   object, if the indexed object exists or undef if the indexed object does
152#   not exist. If a second argument is set, the $index element of the hash will
153#   be set to the value of the argument.
154# ------------------------------------------------------------------------------
155
156for my $name (@hash_properties) {
157  no strict 'refs';
158
159  *$name = sub {
160    my ($self, $arg1, $arg2) = @_;
161
162    # Ensure property is defined as a reference to a hash
163    $self->{$name} = {} if not defined ($self->{$name});
164
165    # Argument 1 can be a reference to a hash or a scalar index
166    my ($index, %hash);
167
168    if (defined $arg1) {
169      if (ref ($arg1) eq 'HASH') {
170        %hash = %$arg1;
171
172      } else {
173        $index = $arg1;
174      }
175    }
176
177    if (defined $index) {
178      # A scalar index is defined, set and/or return the value of an element
179      $self->{$name}{$index} = $arg2 if defined $arg2;
180
181      return (
182        exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
183      );
184
185    } else {
186      # A scalar index is not defined, set and/or return the hash
187      $self->{$name} = \%hash if defined $arg1;
188      return $self->{$name};
189    }
190  }
191}
192
193# ------------------------------------------------------------------------------
194# SYNOPSIS
195#   $rc = $self->check_lock_is_allowed ($lock);
196#
197# DESCRIPTION
198#   This method returns true if it is OK for $lock to exist in the destination.
199# ------------------------------------------------------------------------------
200
201sub check_lock_is_allowed {
202  my ($self, $lock) = @_;
203
204  # Allow existence of build lock in inherited extract
205  return ($lock eq $self->dest->bldlock and @{ $self->inherited });
206}
207
208# ------------------------------------------------------------------------------
209# SYNOPSIS
210#   $rc = $self->invoke_extract ();
211#
212# DESCRIPTION
213#   This method invokes the extract stage of the extract system. It returns
214#   true on success.
215# ------------------------------------------------------------------------------
216
217sub invoke_extract {
218  my $self = shift;
219
220  my $rc = 1;
221
222  my @methods = (
223    'expand_cfg',       # expand URL, revision keywords, relative path, etc
224    'create_dir_stack', # analyse the branches to create an extract sequence
225    'extract_src',      # use the sequence to extract source to destination
226    'write_cfg',        # generate final configuration file
227    'write_cfg_bld',    # generate build configuration file
228  );
229
230  for my $method (@methods) {
231    $rc = $self->$method if $rc;
232  }
233
234  return $rc;
235}
236
237# ------------------------------------------------------------------------------
238# SYNOPSIS
239#   $rc = $self->invoke_mirror ();
240#
241# DESCRIPTION
242#   This method invokes the mirror stage of the extract system. It returns
243#   true on success.
244# ------------------------------------------------------------------------------
245
246sub invoke_mirror {
247  my $self = shift;
248  return $self->rdest->mirror ([qw/bldcfg extcfg srcdir/]);
249}
250
251# ------------------------------------------------------------------------------
252# SYNOPSIS
253#   $rc = $self->invoke_system ();
254#
255# DESCRIPTION
256#   This method invokes the extract system. It returns true on success.
257# ------------------------------------------------------------------------------
258
259sub invoke_system {
260  my $self = shift;
261
262  my $rc = 1;
263 
264  $rc = $self->invoke_stage ('Extract', 'invoke_extract');
265  $rc = $self->invoke_stage ('Mirror', 'invoke_mirror')
266    if $rc and $self->rdest->rootdir;
267
268  return $rc;
269}
270
271# ------------------------------------------------------------------------------
272# SYNOPSIS
273#   $rc = $self->parse_cfg_rdest(\@cfg_lines);
274#
275# DESCRIPTION
276#   This method parses the remote destination settings in the @cfg_lines.
277# ------------------------------------------------------------------------------
278
279sub parse_cfg_rdest {
280  my ($self, $cfg_lines_ref) = @_;
281
282  # RDEST declarations
283  # ----------------------------------------------------------------------------
284  for my $line (grep {$_->slabel_starts_with_cfg('RDEST')} @{$cfg_lines_ref}) {
285    my ($d, $method) = map {lc($_)} $line->slabel_fields();
286    $method ||= 'rootdir';
287    if ($self->rdest()->can($method)) {
288      $self->rdest()->$method(expand_tilde($line->value()));
289      $line->parsed(1);
290    }
291  }
292
293  # MIRROR declaration, deprecated = RDEST::MIRROR_CMD
294  # ----------------------------------------------------------------------------
295  for my $line (grep {$_->slabel_starts_with_cfg('MIRROR')} @{$cfg_lines_ref}) {
296    $self->rdest()->mirror_cmd($line->value());
297    $line->parsed(1);
298  }
299
300  return 1;
301}
302
303# ------------------------------------------------------------------------------
304# SYNOPSIS
305#   $rc = $self->parse_cfg_bld (\@cfg_lines);
306#
307# DESCRIPTION
308#   This method parses the build configurations in the @cfg_lines.
309# ------------------------------------------------------------------------------
310
311sub parse_cfg_bld {
312  my ($self, $cfg_lines) = @_;
313
314  # BLD declarations
315  # ----------------------------------------------------------------------------
316  for my $line (grep {$_->slabel_starts_with_cfg ('BDECLARE')} @$cfg_lines) {
317    # Remove BLD from label
318    my @words = $line->slabel_fields;
319
320    # Check that a declaration follows BLD
321    next if @words <= 1;
322
323    push @{ $self->bdeclare }, FCM1::CfgLine->new (
324      LABEL  => join ($FCM1::Config::DELIMITER, @words),
325      PREFIX => $self->cfglabel ('BDECLARE'),
326      VALUE  => $line->value,
327    );
328    $line->parsed (1);
329  }
330
331  return 1;
332}
333
334# ------------------------------------------------------------------------------
335# SYNOPSIS
336#   $rc = $self->parse_cfg_conflict (\@cfg_lines);
337#
338# DESCRIPTION
339#   This method parses the conflict settings in the @cfg_lines.
340# ------------------------------------------------------------------------------
341
342sub parse_cfg_conflict {
343  my ($self, $cfg_lines) = @_;
344
345  # Deprecated: Override mode setting
346  # ----------------------------------------------------------------------------
347  for my $line (grep {$_->slabel_starts_with_cfg ('OVERRIDE')} @$cfg_lines) {
348    next if ($line->slabel_fields) > 1;
349    $self->conflict ($line->bvalue ? 'override' : 'fail');
350    $line->parsed (1);
351    $line->warning($line->slabel . ' is deprecated. Use ' .
352                   $line->cfglabel('CONFLICT') . ' override|merge|fail.');
353  }
354
355  # Conflict mode setting
356  # ----------------------------------------------------------------------------
357  my @conflict_modes = qw/fail merge override/;
358  my $conflict_modes_pattern = join ('|', @conflict_modes);
359  for my $line (grep {$_->slabel_starts_with_cfg ('CONFLICT')} @$cfg_lines) {
360    if ($line->value =~ /$conflict_modes_pattern/i) {
361      $self->conflict (lc ($line->value));
362      $line->parsed (1);
363
364    } elsif ($line->value =~ /^[012]$/) {
365      $self->conflict ($conflict_modes[$line->value]);
366      $line->parsed (1);
367
368    } else {
369      $line->error ($line->value, ': invalid value');
370    }
371  }
372
373  return 1;
374}
375
376# ------------------------------------------------------------------------------
377# SYNOPSIS
378#   $rc = $self->parse_cfg_project (\@cfg_lines);
379#
380# DESCRIPTION
381#   This method parses the project settings in the @cfg_lines.
382# ------------------------------------------------------------------------------
383
384sub parse_cfg_project {
385  my ($self, $cfg_lines) = @_;
386
387  # Flag to indicate that a declared branch revision must match with its changed
388  # revision
389  # ----------------------------------------------------------------------------
390  for my $line (grep {$_->slabel_starts_with_cfg ('REVMATCH')} @$cfg_lines) {
391    next if ($line->slabel_fields) > 1;
392    $self->setting ([qw/EXT_REVMATCH/], $line->bvalue);
393    $line->parsed (1);
394  }
395
396  # Repository, revision and source directories
397  # ----------------------------------------------------------------------------
398  for my $name (qw/repos revision dirs expdirs/) {
399    my @lines = grep {
400      $_->slabel_starts_with_cfg (uc ($name)) or
401      $name eq 'revision' and $_->slabel_starts_with_cfg ('VERSION');
402    } @$cfg_lines;
403    for my $line (@lines) {
404      my @names = $line->slabel_fields;
405      shift @names;
406
407      # Detemine package and tag
408      my $tag     = pop @names;
409      my $pckroot = $names[0];
410      my $pck     = join ($FCM1::Config::DELIMITER, @names);
411
412      # Check that $tag and $pckroot are defined
413      next unless $tag and $pckroot;
414
415      # Check if branch already exists.
416      # If so, set $branch to point to existing branch
417      my $branch = undef;
418      for (@{ $self->branches }) {
419        next unless $_->package eq $pckroot and $_->tag eq $tag;
420
421        $branch = $_;
422        last;
423      }
424
425      # Otherwise, create a new branch
426      if (not $branch) {
427        $branch = FCM1::ReposBranch->new (PACKAGE => $pckroot, TAG => $tag,);
428
429        push @{ $self->branches }, $branch;
430      }
431
432      if ($name eq 'repos' or $name eq 'revision') {
433        # Branch location or revision
434        $branch->$name ($line->value);
435
436      } else { # $name eq 'dirs' or $name eq 'expdirs'
437        # Source directory or expandable source directory
438        if ($pck eq $pckroot and $line->value !~ m#^/#) {
439          # Sub-package name not set and source directory quoted as a relative
440          # path, determine package name from path name
441          $pck = join (
442            $FCM1::Config::DELIMITER,
443            ($pckroot, File::Spec->splitdir ($line->value)),
444          );
445        }
446
447        # A "/" is equivalent to the top (empty) package
448        my $value = ($line->value =~ m#^/+$#) ? '' : $line->value;
449        $branch->$name ($pck, $value);
450      }
451
452      $line->parsed (1);
453    }
454  }
455
456  return 1;
457}
458
459# ------------------------------------------------------------------------------
460# SYNOPSIS
461#   $rc = $obj->expand_cfg ();
462#
463# DESCRIPTION
464#   This method expands the settings of the extract configuration.
465# ------------------------------------------------------------------------------
466
467sub expand_cfg {
468  my $self = shift;
469
470  my $rc = 1;
471  for my $use (@{ $self->inherit }) {
472    $rc = $use->expand_cfg if $rc;
473  }
474
475  return $rc unless $rc;
476
477  # Establish a set of source directories from the "base repository"
478  my %base_branches = ();
479
480  # Inherit "base" set of source directories from re-used extracts
481  for my $use (@{ $self->inherit }) {
482    my @branches = @{ $use->branches };
483
484    for my $branch (@branches) {
485      my $package              = $branch->package;
486      $base_branches{$package} = $branch unless exists $base_branches{$package};
487    }
488  }
489
490  for my $branch (@{ $self->branches }) {
491    # Expand URL keywords if necessary
492    if ($branch->repos) {
493      my $repos = FCM1::Util::tidy_url(FCM1::Keyword::expand($branch->repos()));
494      $branch->repos ($repos) if $repos ne $branch->repos;
495    }
496
497    # Check that repository type and revision are set
498    if ($branch->repos and &is_url ($branch->repos)) {
499      $branch->type ('svn') unless $branch->type;
500      $branch->revision ('head') unless $branch->revision;
501
502    } else {
503      $branch->type ('user') unless $branch->type;
504      $branch->revision ('user') unless $branch->revision;
505    }
506
507    $rc = $branch->expand_revision if $rc; # Get revision number from keywords
508    $rc = $branch->expand_path     if $rc; # Expand relative path to full path
509    $rc = $branch->expand_all      if $rc; # Search sub-directories
510    last unless $rc;
511
512    my $package = $branch->package;
513
514    if (exists $base_branches{$package}) {
515      # A base branch for this package exists
516
517      # If current branch has no source directory, use the set provided by the
518      # base branch
519      my %dirs = %{ $branch->dirs };
520      $branch->add_base_dirs ($base_branches{$package}) unless keys %dirs;
521
522    } else {
523      # This package does not yet have a base branch, set this branch as base
524      $base_branches{$package} = $branch;
525    }
526  }
527
528  return $rc;
529}
530
531# ------------------------------------------------------------------------------
532# SYNOPSIS
533#   $rc = $obj->create_dir_stack ();
534#
535# DESCRIPTION
536#   This method creates a hash of source directories to be processed. If the
537#   flag INHERITED is set to true, the source directories are assumed processed
538#   and extracted.
539# ------------------------------------------------------------------------------
540
541sub create_dir_stack {
542  my $self = shift;
543  my %args = @_;
544
545  # Inherit from USE ext cfg
546  for my $use (@{ $self->inherit }) {
547    $use->create_dir_stack () or return 0;
548    my %use_srcdirs = %{ $use->srcdirs };
549
550    while (my ($key, $value) = each %use_srcdirs) {
551      $self->srcdirs ($key, $value);
552
553      # Re-set destination to current destination
554      my @path = split (/$FCM1::Config::DELIMITER/, $key);
555      $self->srcdirs ($key)->{DEST} = File::Spec->catfile (
556        $self->dest->srcdir, @path,
557      );
558    }
559  }
560
561  # Build stack from current ext cfg
562  for my $branch (@{ $self->branches }) {
563    my %branch_dirs = %{ $branch->dirs };
564
565    for my $dir (keys %branch_dirs) {
566      # Check whether source directory is already in the list
567      if (not $self->srcdirs ($dir)) { # if not, create it
568        $self->srcdirs ($dir, {
569          DEST  => File::Spec->catfile (
570            $self->dest->srcdir, split (/$FCM1::Config::DELIMITER/, $dir)
571          ),
572          STACK => [],
573          FILES => {},
574        });
575      }
576
577      my $stack = $self->srcdirs ($dir)->{STACK}; # copy reference
578
579      # Create a new layer in the input stack
580      my $layer = FCM1::SrcDirLayer->new (
581        NAME      => $dir,
582        PACKAGE   => $branch->package,
583        TAG       => $branch->tag,
584        LOCATION  => $branch->dirs ($dir),
585        REPOSROOT => $branch->repos,
586        REVISION  => $branch->revision,
587        TYPE      => $branch->type,
588        EXTRACTED => @{ $self->inherited }
589                     ? $self->srcdirs ($dir)->{DEST} : undef,
590      );
591
592      # Check whether layer is already in the stack
593      my $exist = grep {
594        $_->location eq $layer->location and $_->revision eq $layer->revision;
595      } @{ $stack };
596
597      if (not $exist) {
598        # If not already exist, put layer into stack
599
600        # Note: user stack always comes last
601        if (! $layer->user and exists $stack->[-1] and $stack->[-1]->user) {
602          my $lastlayer = pop @{ $stack };
603          push @{ $stack }, $layer;
604          $layer = $lastlayer;
605        }
606
607        push @{ $stack }, $layer;
608
609      } elsif ($layer->user) {
610
611        # User layer already exists, overwrite it
612        $stack->[-1] = $layer;
613
614      }
615    }
616  }
617
618  # Use the cache to sort the source directory layer hash
619  return $self->compare_setting (METHOD_LIST => ['sort_dir_stack']);
620}
621
622# ------------------------------------------------------------------------------
623# SYNOPSIS
624#   ($rc, \@new_lines) = $self->sort_dir_stack ($old_lines);
625#
626# DESCRIPTION
627#   This method sorts thesource directories hash to be processed.
628# ------------------------------------------------------------------------------
629
630sub sort_dir_stack {
631  my ($self, $old_lines) = @_;
632
633  my $rc = 0;
634
635  my %old = ();
636  if ($old_lines) {
637    for my $line (@$old_lines) {
638      $old{$line->label} = $line->value;
639    }
640  }
641
642  my %new;
643
644  # Compare each layer to base layer, discard unnecessary layers
645  DIR: for my $srcdir (keys %{ $self->srcdirs }) {
646    my @stack = ();
647
648    while (my $layer = shift @{ $self->srcdirs ($srcdir)->{STACK} }) {
649      if ($layer->user) {
650        # Local file system branch, check that the declared location exists
651        if (-d $layer->location) {
652          # Local file system branch always takes precedence
653          push @stack, $layer;
654
655        } else {
656          w_report 'ERROR: ', $layer->location, ': declared source directory ',
657                   'does not exists ';
658          $rc = undef;
659          last DIR;
660        }
661
662      } else {
663        my $key = join ($FCM1::Config::DELIMITER, (
664          $srcdir, $layer->location, $layer->revision
665        ));
666
667        unless ($layer->extracted and $layer->commit) {
668          # See if commit revision information is cached
669          if (keys %old and exists $old{$key}) {
670            $layer->commit ($old{$key});
671
672          } else {
673            $layer->get_commit;
674            $rc = 1;
675          }
676
677          # Check source directory for commit revision, if necessary
678          if (not $layer->commit) {
679            w_report 'Error: cannot determine the last changed revision of ',
680                     $layer->location;
681            $rc = undef;
682            last DIR;
683          }
684
685          # Set cache directory for layer
686          my $tag_ver = $layer->tag . '__' . $layer->commit;
687          $layer->cachedir (File::Spec->catfile (
688            $self->dest->cachedir,
689            split (/$FCM1::Config::DELIMITER/, $srcdir),
690            $tag_ver,
691          ));
692        }
693
694        # New line in cache config file
695        $new{$key} = $layer->commit;
696
697        # Push this layer in the stack:
698        # 1. it has a different revision compared to the top layer
699        # 2. it is the top layer (base line code)
700        if (@stack > 0) {
701          push @stack, $layer if $layer->commit != $stack[0]->commit;
702
703        } else {
704          push @stack, $layer;
705        }
706
707      }
708    }
709
710    $self->srcdirs ($srcdir)->{STACK} = \@stack;
711  }
712
713  # Write "commit cache" file
714  my @new_lines;
715  if (defined ($rc)) {
716    for my $key (sort keys %new) {
717      push @new_lines, FCM1::CfgLine->new (label => $key, value => $new{$key});
718    }
719  }
720
721  return ($rc, \@new_lines);
722}
723
724# ------------------------------------------------------------------------------
725# SYNOPSIS
726#   $rc = $self->extract_src ();
727#
728# DESCRIPTION
729#   This internal method performs the extract of the source directories and
730#   files if necessary.
731# ------------------------------------------------------------------------------
732
733sub extract_src {
734  my $self = shift;
735  my $rc = 1;
736
737  # Ensure destinations exist and are directories
738  for my $srcdir (values %{ $self->srcdirs }) {
739    last if not $rc;
740    if (-f $srcdir->{DEST}) {
741      w_report $srcdir->{DEST},
742               ': destination exists and is not a directory, abort.';
743      $rc = 0;
744    }
745  }
746
747  # Retrieve previous/record current extract configuration for each file.
748  $rc = $self->compare_setting (
749    CACHEBASE => $self->setting ('CACHE_FILE_SRC'),
750    METHOD_LIST => ['compare_setting_srcfiles'],
751  ) if $rc;
752
753  return $rc;
754}
755
756# ------------------------------------------------------------------------------
757# SYNOPSIS
758#   ($rc, \@new_lines) = $self->compare_setting_srcfiles ($old_lines);
759#
760# DESCRIPTION
761#   For each file to be extracted, this method creates an instance of an
762#   FCM1::ExtractFile object. It then compares its file's sources to determine
763#   if they have changed. If so, it will allow the FCM1::ExtractFile to
764#   "re-extract" the file to the destination. Otherwise, it will set
765#   FCM1::ExtractFile->dest_status to a null string to denote an "unchanged"
766#   dest_status.
767#
768# SEE ALSO
769#   FCM1::ConfigSystem->compare_setting.
770# ------------------------------------------------------------------------------
771
772sub compare_setting_srcfiles {
773  my ($self, $old_lines) = @_;
774  my $rc = 1;
775
776  # Retrieve previous extract configuration for each file
777  # ----------------------------------------------------------------------------
778  my %old = ();
779  if ($old_lines) {
780    for my $line (@$old_lines) {
781      $old{$line->label} = $line->value;
782    }
783  }
784
785  # Build up a sequence using a FCM1::ExtractFile object for each file
786  # ----------------------------------------------------------------------------
787  for my $srcdir (values %{ $self->srcdirs }) {
788    my %pkgnames0; # (to be) list of package names in the base layer
789    for my $i (0 .. @{ $srcdir->{STACK} } - 1) {
790      my $layer = $srcdir->{STACK}->[$i];
791      # Update the cache for each layer of the stack if necessary
792      $layer->update_cache unless $layer->extracted or -d $layer->localdir;
793
794      # Get list of files in the cache or local directory
795      my %pkgnames;
796      for my $file (($layer->get_files)) {
797        my $pkgname = join (
798          '/', split (/$FCM1::Config::DELIMITER/, $layer->name), $file
799        );
800        $pkgnames0{$pkgname} = 1 if $i == 0; # store package name in base layer
801        $pkgnames{$pkgname} = 1; # store package name in the current layer
802        if (not $self->files ($pkgname)) {
803          $self->files ($pkgname, FCM1::ExtractFile->new (
804            conflict => $self->conflict,
805            dest     => $self->dest->srcpath,
806            pkgname  => $pkgname,
807          ));
808
809          # Base is empty
810          $self->files ($pkgname)->src->[0] = FCM1::ExtractSrc->new (
811            id      => $layer->tag,
812            pkgname => $pkgname,
813          ) if $i > 0;
814        }
815        my $cache = File::Spec->catfile ($layer->localdir, $file);
816        push @{ $self->files ($pkgname)->src }, FCM1::ExtractSrc->new (
817          cache   => $cache,
818          id      => $layer->tag,
819          pkgname => $pkgname,
820          rev     => ($layer->user ? (stat ($cache))[9] : $layer->commit),
821          uri     => join ('/', $layer->location, $file),
822        );
823      }
824
825      # List of removed files in this layer (relative to base layer)
826      if ($i > 0) {
827        for my $pkgname (keys %pkgnames0) {
828          push @{ $self->files ($pkgname)->src }, FCM1::ExtractSrc->new (
829            id      => $layer->tag,
830            pkgname => $pkgname,
831          ) if not exists $pkgnames{$pkgname}
832        }
833      }
834    }
835  }
836
837  # Compare with old settings
838  # ----------------------------------------------------------------------------
839  my %new = ();
840  for my $key (sort keys %{ $self->files }) {
841    # Set up value for cache
842    my @sources = ();
843    for my $src (@{ $self->files ($key)->src }) {
844      push @sources, (defined ($src->uri) ? ($src->uri . '@' . $src->rev) : '');
845    }
846
847    my $value = join ($FCM1::Config::DELIMITER, @sources);
848
849    # Set FCM1::ExtractFile->dest_status to "unchanged" if value is unchanged
850    if (exists($old{$key}) && $old{$key} eq $value && !grep {!$_} @sources) {
851      $self->files($key)->dest_status('');
852    }
853
854    # Write current settings
855    $new{$key} = $value;
856  }
857
858  # Delete those that exist in previous extract but not in current
859  # ----------------------------------------------------------------------------
860  for my $key (sort keys %old) {
861    next if exists $new{$key};
862    $self->files ($key, FCM1::ExtractFile->new (
863      dest    => $self->dest->srcpath,
864      pkgname => $key,
865    ));
866  }
867
868  # Extract each file, if necessary
869  # ----------------------------------------------------------------------------
870  for my $key (sort keys %{ $self->files }) {
871    $rc = $self->files ($key)->run if defined ($rc);
872    last if not defined ($rc);
873  }
874
875  # Report status
876  # ----------------------------------------------------------------------------
877  if (defined ($rc) and $self->verbose) {
878    my %src_status_count = ();
879    my %dest_status_count = ();
880    for my $key (sort keys %{ $self->files }) {
881      # Report changes in destination in verbose 1 or above
882      my $dest_status = $self->files ($key)->dest_status;
883      my $src_status = $self->files ($key)->src_status;
884      next unless $self->verbose and $dest_status;
885
886      if ($dest_status and $dest_status ne '?') {
887        if (exists $dest_status_count{$dest_status}) {
888          $dest_status_count{$dest_status}++;
889
890        } else {
891          $dest_status_count{$dest_status} = 1;
892        }
893      }
894
895      if ($src_status and $src_status ne '?') {
896        if (exists $src_status_count{$src_status}) {
897          $src_status_count{$src_status}++;
898
899        } else {
900          $src_status_count{$src_status} = 1;
901        }
902      }
903
904      # Destination status in column 1, source status in column 2
905      if ($self->verbose > 1) {
906        my @srcs = @{$self->files ($key)->src_actual};
907        print ($dest_status ? $dest_status : ' ');
908        print ($src_status ? $src_status : ' ');
909        print ' ' x 5, $key;
910        print ' (', join (', ', map {$_->id} @srcs), ')' if @srcs;
911        print "\n";
912      }
913    }
914
915    # Report number of files in each dest_status category
916    if (%dest_status_count) {
917      print 'Column 1: ' if $self->verbose > 1;
918      print 'Destination status summary:', "\n";
919      for my $key (sort keys %FCM1::ExtractFile::DEST_STATUS_CODE) {
920        next unless $key;
921        next if not exists ($dest_status_count{$key});
922        print '  No of files ';
923        print '[', $key, '] ' if $self->verbose > 1;
924        print $FCM1::ExtractFile::DEST_STATUS_CODE{$key}, ': ',
925              $dest_status_count{$key}, "\n";
926      }
927    }
928
929    # Report number of files in each dest_status category
930    if (%src_status_count) {
931      print 'Column 2: ' if $self->verbose > 1;
932      print 'Source status summary:', "\n";
933      for my $key (sort keys %FCM1::ExtractFile::SRC_STATUS_CODE) {
934        next unless $key;
935        next if not exists ($src_status_count{$key});
936        print '  No of files ';
937        print '[', $key, '] ' if $self->verbose > 1;
938        print $FCM1::ExtractFile::SRC_STATUS_CODE{$key}, ': ',
939              $src_status_count{$key}, "\n";
940      }
941    }
942  }
943
944  # Record configuration of current extract for each file
945  # ----------------------------------------------------------------------------
946  my @new_lines;
947  if (defined ($rc)) {
948    for my $key (sort keys %new) {
949      push @new_lines, FCM1::CfgLine->new (label => $key, value => $new{$key});
950    }
951  }
952
953  return ($rc, \@new_lines);
954}
955
956# ------------------------------------------------------------------------------
957# SYNOPSIS
958#   @array = $self->sort_bdeclare ();
959#
960# DESCRIPTION
961#   This method returns sorted build declarations, filtering out repeated
962#   entries, where possible.
963# ------------------------------------------------------------------------------
964
965sub sort_bdeclare {
966  my $self = shift;
967
968  # Get list of build configuration labels that can be declared multiple times
969  my %cfg_keyword = map {
970    ($self->cfglabel ($_), 1)
971  } split (/$FCM1::Config::DELIMITER_LIST/, $self->setting ('CFG_KEYWORD'));
972
973  my @bdeclares = ();
974  for my $d (reverse @{ $self->bdeclare }) {
975    # Reconstruct array from bottom up
976    # * always add declarations that can be declared multiple times
977    # * otherwise add only if it is declared below
978    unshift @bdeclares, $d
979      if exists $cfg_keyword{uc (($d->slabel_fields)[0])} or
980         not grep {$_->slabel eq $d->slabel} @bdeclares;
981  }
982
983  return (sort {$a->slabel cmp $b->slabel} @bdeclares);
984}
985
986# ------------------------------------------------------------------------------
987# SYNOPSIS
988#   @cfglines = $obj->to_cfglines ();
989#
990# DESCRIPTION
991#   See description of FCM1::ConfigSystem->to_cfglines for further information.
992# ------------------------------------------------------------------------------
993
994sub to_cfglines {
995  my ($self) = @_;
996
997  return (
998    FCM1::ConfigSystem::to_cfglines($self),
999
1000    $self->rdest->to_cfglines (),
1001    FCM1::CfgLine->new (),
1002
1003    @{ $self->bdeclare } ? (
1004      FCM1::CfgLine::comment_block ('Build declarations'),
1005      map {
1006        FCM1::CfgLine->new (label => $_->label, value => $_->value)
1007      } ($self->sort_bdeclare),
1008      FCM1::CfgLine->new (),
1009    ) : (),
1010
1011    FCM1::CfgLine::comment_block ('Project and branches'),
1012    (map {($_->to_cfglines ())} @{ $self->branches }),
1013
1014    ($self->conflict ne 'merge') ? (
1015      FCM1::CfgLine->new (
1016        label => $self->cfglabel ('CONFLICT'), value => $self->conflict,
1017      ),
1018      FCM1::CfgLine->new (),
1019    ) : (),
1020  );
1021}
1022
1023# ------------------------------------------------------------------------------
1024# SYNOPSIS
1025#   @cfglines = $obj->to_cfglines_bld ();
1026#
1027# DESCRIPTION
1028#   Returns a list of configuration lines of the current extract suitable for
1029#   feeding into the build system.
1030# ------------------------------------------------------------------------------
1031
1032sub to_cfglines_bld {
1033  my ($self) = @_;
1034
1035  my $dest = $self->rdest->rootdir ? 'rdest' : 'dest';
1036  my $root = File::Spec->catfile ('$HERE', '..');
1037
1038  my @inherits;
1039  my @no_inherits;
1040  if (@{ $self->inherit }) {
1041    # List of inherited builds
1042    for (@{ $self->inherit }) {
1043      push @inherits, FCM1::CfgLine->new (
1044        label => $self->cfglabel ('USE'), value => $_->$dest->rootdir
1045      );
1046    }
1047
1048    # List of files that should not be inherited
1049    for my $key (sort keys %{ $self->files }) {
1050      next unless $self->files ($key)->dest_status eq 'd';
1051      my $label = join ('::', (
1052        $self->cfglabel ('INHERIT'),
1053        $self->cfglabel ('FILE'),
1054        split (m#/#, $self->files ($key)->pkgname),
1055      ));
1056      push @no_inherits, FCM1::CfgLine->new (label => $label, value => 'false');
1057    }
1058  }
1059
1060  return (
1061    FCM1::CfgLine::comment_block ('File header'),
1062    (map
1063      {my ($lbl, $val) = @{$_}; FCM1::CfgLine->new(label => $lbl, value => $val)}
1064      (
1065        [$self->cfglabel('CFGFILE') . $FCM1::Config::DELIMITER . 'TYPE'   , 'bld'],
1066        [$self->cfglabel('CFGFILE') . $FCM1::Config::DELIMITER . 'VERSION', '1.0'],
1067        [],
1068      )
1069    ),
1070
1071    @{ $self->inherit } ? (
1072      @inherits,
1073      @no_inherits,
1074      FCM1::CfgLine->new (),
1075    ) : (),
1076
1077    FCM1::CfgLine::comment_block ('Destination'),
1078    FCM1::CfgLine->new (label => $self->cfglabel ('DEST'), value => $root),
1079    FCM1::CfgLine->new (),
1080
1081    @{ $self->bdeclare } ? (
1082      FCM1::CfgLine::comment_block ('Build declarations'),
1083      map {
1084        FCM1::CfgLine->new (label => $_->slabel, value => $_->value)
1085      } ($self->sort_bdeclare),
1086      FCM1::CfgLine->new (),
1087    ) : (),
1088  );
1089}
1090
1091# ------------------------------------------------------------------------------
1092# SYNOPSIS
1093#   $rc = $self->write_cfg ();
1094#
1095# DESCRIPTION
1096#   This method writes the configuration file at the end of the run. It calls
1097#   $self->write_cfg_system ($cfg) to write any system specific settings.
1098# ------------------------------------------------------------------------------
1099
1100sub write_cfg {
1101  my $self = shift;
1102
1103  my $cfg = FCM1::CfgFile->new (TYPE => $self->type);
1104  $cfg->lines ([$self->to_cfglines()]);
1105  $cfg->print_cfg ($self->dest->extcfg);
1106
1107  return 1;
1108}
1109
1110# ------------------------------------------------------------------------------
1111# SYNOPSIS
1112#   $rc = $self->write_cfg_bld ();
1113#
1114# DESCRIPTION
1115#   This internal method writes the build configuration file.
1116# ------------------------------------------------------------------------------
1117
1118sub write_cfg_bld {
1119  my $self = shift;
1120
1121  my $cfg = FCM1::CfgFile->new (TYPE => 'bld');
1122  $cfg->lines ([$self->to_cfglines_bld()]);
1123  $cfg->print_cfg ($self->dest->bldcfg);
1124
1125  return 1;
1126}
1127
1128# ------------------------------------------------------------------------------
1129
11301;
1131
1132__END__
Note: See TracBrowser for help on using the repository browser.