source: XMLIO_V2/tools/FCM/lib/Fcm/Extract.pm @ 81

Last change on this file since 81 was 81, checked in by ymipsl, 15 years ago

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