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

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

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