source: codes/icosagcm/trunk/tools/FCM/lib/Fcm/Extract.pm @ 10

Last change on this file since 10 was 10, checked in by ymipsl, 12 years ago

dynamico tree creation

YM
File size: 51.0 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   Fcm::Extract
5#
6# DESCRIPTION
7#   This class contains methods for carrying out the various tasks that are
8#   required to extract code from the FCM Subversion repository for feeding
9#   into the prototype build system. At the end of the extract, it writes a
10#   build configuration file for feeding into the build system.  If the code
11#   is to be built on a remote machine, it is mirrored to the remote machine
12#   using a "rdist" or "rsync" interface.
13#
14# COPYRIGHT
15#   (C) Crown copyright Met Office. All rights reserved.
16#   For further details please refer to the file COPYRIGHT.txt
17#   which you should have received as part of this distribution.
18# ------------------------------------------------------------------------------
19
20package Fcm::Extract;
21
22# Standard pragma
23use warnings;
24use strict;
25
26# Standard modules
27use Carp;
28use File::Spec;
29use File::Spec::Functions;
30use File::Basename;
31use File::Path;
32use File::Compare;
33
34# FCM component modules
35use Fcm::CfgFile;
36use Fcm::ReposBranch;
37use Fcm::SrcDirLayer;
38use Fcm::Util;
39use Fcm::Timer;
40
41# ------------------------------------------------------------------------------
42# SYNOPSIS
43#   $ext = Fcm::Extract->new (
44#     CONFIG    => $config,
45#     CFG_SRC   => $cfg_src,
46#     EXTRACTED => $extracted,
47#   );
48#
49# DESCRIPTION
50#   This method constructs a new instance of the Fcm::Extract class.
51#
52# ARGUMENTS
53#   CONFIG     - reference to a Fcm::Config instance
54#   CFG_SRC    - source path to the extract configuration file
55#   EXTRACTED  - is it a pre-extracted object?
56# ------------------------------------------------------------------------------
57
58sub new {
59  my $this  = shift;
60  my %args  = @_;
61  my $class = ref $this || $this;
62
63  my $cfg       = exists $args{CFG_SRC}   ? $args{CFG_SRC}   : undef;
64  my $extracted = exists $args{EXTRACTED} ? $args{EXTRACTED} : undef;
65  my $config    = exists $args{CONFIG}    ? $args{CONFIG}    : &main::cfg;
66
67  my $self = {
68    CONFIG     => $config,            # configuration settings
69    CFG        => Fcm::CfgFile->new ( # ext cfg for this extract
70      SRC      => $cfg,               # source path of the config file
71      TYPE     => 'ext',              # config file type
72      CONFIG   => $config,            # configuration settings
73    ),
74    DEST       => {                   # destination info for this extract
75      ROOTDIR  => undef,              # destination root directory
76      CACHEDIR => undef,              # extract cache directory
77      CFGDIR   => undef,              # destination configuration directory
78      SRCDIR   => undef,              # destination source directory
79      BLD_CFG  => undef,              # bld cfg for the build system
80      EXT_CFG  => undef,              # ext cfg for subsequent extract
81    },
82    RDEST      => {                   # remote destination information
83      MACHINE  => undef,              # destination machine
84      LOGNAME  => undef,              # remote login name
85      ROOTDIR  => undef,              # destination root directory
86      CFGDIR   => undef,              # destination configuration directory
87      SRCDIR   => undef,              # destination source directory
88      BLD_CFG  => undef,              # bld cfg for the build system
89      EXT_CFG  => undef,              # ext cfg for subsequent extract
90    },
91    BDECLARE   => [],                 # list of declared bld cfg entries
92    OVERRIDE   => 0,                  # override conflicting patches?
93    EXTRACTED  => $extracted,         # is the current object pre-extracted?
94    USE        => [],                 # list of re-used extracts
95    BRANCHES   => [],                 # list of repository branch info
96    SRCDIRS    => {},                 # list of source directory extract info
97    LOCK       => undef,              # lock file
98  };
99  bless $self, $class;
100  return $self;
101}
102
103# ------------------------------------------------------------------------------
104# SYNOPSIS
105#   $self->DESTROY;
106#
107# DESCRIPTION
108#   This method is called automatically when a Fcm::Extract object is
109#   destroyed.
110# ------------------------------------------------------------------------------
111
112sub DESTROY {
113  my $self = shift;
114
115  # Remove the lock if it is set
116  unlink $self->{LOCK} if $self->{LOCK} and -e $self->{LOCK};
117
118  return;
119}
120
121# ------------------------------------------------------------------------------
122# SYNOPSIS
123#   $config = $ext->config;
124#
125# DESCRIPTION
126#   This method returns a reference to the Fcm::Config instance.
127# ------------------------------------------------------------------------------
128
129sub config {
130  my $self = shift;
131
132  return $self->{CONFIG};
133}
134
135# ------------------------------------------------------------------------------
136# SYNOPSIS
137#   $cfgfile = $ext->cfg;
138#   $ext->cfg ($cfgfile);
139#
140# DESCRIPTION
141#   This method returns a reference to a Fcm::CfgFile instance for the extract
142#   configuration file.
143# ------------------------------------------------------------------------------
144
145sub cfg {
146  my $self = shift;
147
148  return $self->{CFG};
149}
150
151# ------------------------------------------------------------------------------
152# SYNOPSIS
153#   $dest = $ext->dest ([$name]);
154#
155# DESCRIPTION
156#   This method returns a hash containing the extract destination information
157#   (local) if no argument is specified. If $name is specified, it returns the
158#   named hash element if it exists.
159# ------------------------------------------------------------------------------
160
161sub dest {
162  my $self = shift;
163
164  if (@_) {
165    my $name = shift;
166    $name    = uc $name;
167
168    if (exists $self->{DEST}{$name}) {
169      return $self->{DEST}{$name};
170    }
171  }
172
173  return %{ $self->{DEST} };
174}
175
176# ------------------------------------------------------------------------------
177# SYNOPSIS
178#   $rdest = $ext->rdest ([$name]);
179#
180# DESCRIPTION
181#   This method returns a hash containing the extract destination information
182#   (remote) if no argument is specified. If $name is specified, it returns the
183#   named hash element if it exists.
184# ------------------------------------------------------------------------------
185
186sub rdest {
187  my $self = shift;
188
189  if (@_) {
190    my $name = shift;
191    $name    = uc $name;
192
193    if (exists $self->{RDEST}{$name}) {
194      return $self->{RDEST}{$name};
195    }
196  }
197
198  return %{ $self->{RDEST} };
199}
200
201# ------------------------------------------------------------------------------
202# SYNOPSIS
203#   @bdeclare = $ext->bdeclare ();
204#
205# DESCRIPTION
206#   This method returns a list containing the build configuration file entries.
207# ------------------------------------------------------------------------------
208
209sub bdeclare {
210  my $self = shift;
211
212  return @{ $self->{BDECLARE} };
213}
214
215# ------------------------------------------------------------------------------
216# SYNOPSIS
217#   @branches = $ext->branches ([$index]);
218#
219# DESCRIPTION
220#   This method returns a list of references to Fcm::ReposBranch instances. If
221#   $index is specified, it returns the numbered item in the list.
222# ------------------------------------------------------------------------------
223
224sub branches {
225  my $self = shift;
226
227  if (@_) {
228    my $index = $_[0];
229    return exists $self->{BRANCHES}[$index] ? $self->{BRANCHES}[$index] : undef;
230  }
231
232  return @{ $self->{BRANCHES} };
233}
234
235# ------------------------------------------------------------------------------
236# SYNOPSIS
237#   %srcdirs = $ext->srcdirs ([$name]);
238#
239# DESCRIPTION
240#   This method returns a hash of source directories to be processed by this
241#   extract. If $name is specified, a named element of the hash is returned
242#   instead.
243# ------------------------------------------------------------------------------
244
245sub srcdirs {
246  my $self = shift;
247
248  if (@_) {
249    my $name = shift;
250    $name    = uc $name;
251
252    return exists $self->{SRCDIRS}{$name} ? $self->{SRCDIRS}{$name} : undef;
253  }
254
255  return %{ $self->{SRCDIRS} };
256}
257
258# ------------------------------------------------------------------------------
259# SYNOPSIS
260#   $rc = $ext->extract ([FULL => 1], [IGNORE_LOCK => 1]);
261#
262# DESCRIPTION
263#   This is the main class method. It performs an extract using the current
264#   configuration. If FULL is set to true, it runs in full mode. Otherwise, it
265#   runs in incremental mode. If IGNORE_LOCK is set to true, it ignores any lock
266#   files that may exist in the extract destination root directory.
267# ------------------------------------------------------------------------------
268
269sub extract {
270  my $self = shift;
271  my %args = @_;
272
273  my $full        = exists $args{FULL}        ? $args{FULL}        : 0;
274  my $ignore_lock = exists $args{IGNORE_LOCK} ? $args{IGNORE_LOCK} : 0;
275
276  my $verbose = $self->config->verbose;
277
278  my $date = localtime;
279  print 'Extract started on ', $date, '.', "\n" if $verbose;
280  my $otime = time;
281
282  my $rc;
283  $rc = $self->decipher_cfg;
284
285  print '->Extract: start', "\n" if $verbose;
286  my $stime = time;
287
288  $rc = $self->check_dest               if $rc;
289  $rc = $self->check_lock               if $rc and not $ignore_lock;
290  $rc = $self->_set_lock                if $rc;
291  $rc = $self->expand_cfg               if $rc;
292  $rc = $self->_create_dest_dir ($full) if $rc;
293  $rc = $self->create_dir_stack         if $rc;
294  $rc = $self->_extract_src             if $rc;
295
296  $rc = $self->_sort_bdeclare if $rc;
297  $rc = $self->_write_ext_cfg if $rc;
298  $rc = $self->_write_bld_cfg if $rc;
299
300  my $ftime = time;
301  my $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
302  print '->Extract: ', $ftime - $stime, ' ', $s_str, "\n";
303
304  if ($rc and $self->{RDEST}{MACHINE}) {
305    print '->Mirror : start', "\n" if $verbose;
306    $stime = time;
307    $rc = $self->_mirror_extract;
308    $ftime = time;
309    $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
310    print '->Mirror : ', $ftime - $stime, ' ', $s_str, "\n";
311  }
312
313  if ($verbose) {
314    $s_str = $ftime - $otime > 1 ? 'seconds' : 'second';
315    print '->TOTAL  : ', $ftime - $otime, ' ', $s_str, "\n";
316  }
317
318  $date = localtime;
319  if ($rc) {
320    print 'Extract command finished on ', $date, '.', "\n" if $verbose;
321
322  } else {
323    e_report 'Extract command failed on ', $date, '.';
324  }
325
326  return $rc;
327}
328
329# ------------------------------------------------------------------------------
330# SYNOPSIS
331#   $ext->decipher_cfg ();
332#
333# DESCRIPTION
334#   This method deciphers the extract configuration file.
335# ------------------------------------------------------------------------------
336
337sub decipher_cfg {
338  my $self = shift;
339
340  return unless $self->cfg->src;
341
342  # Read config file
343  my $read = $self->cfg->read_cfg;
344
345  # Check config file type
346  if ($read) {
347    if ($self->cfg->type ne 'ext') {
348      w_report 'Error: ', $self->cfg->src, ': not an extract config file';
349      return;
350    }
351
352  } else {
353    return;
354  }
355
356  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
357
358  # Extract information from each line of the config file
359  my @lines    = $self->cfg->lines;
360  LINE: for my $line (@lines) {
361    my $label = $line->{LABEL};
362    my $value = $line->{VALUE};
363
364    next LINE unless $label;
365
366    # Configuration file type/version, ignore
367    for my $my_label (keys %{ $cfg_labels{CFGFILE} }) {
368      next LINE if uc ($label) eq uc ($cfg_labels{CFGFILE}{$my_label});
369    }
370
371    # Include another file, processed already, ignore this line
372    next LINE if uc ($label) eq $cfg_labels{INC};
373
374    # User variable, ignore
375    next LINE if index (uc ($label), '%') == 0;
376
377    # Local destination directories, config file, etc
378    for my $my_label (keys %{ $cfg_labels{DEST} }) {
379      if (uc ($label) eq uc ($cfg_labels{DEST}{$my_label})) {
380        $self->{DEST}{$my_label} = &expand_tilde ($value);
381        next LINE;
382      }
383    }
384
385    # Remote machine, logname, destination directories, config file, etc
386    for my $my_label (keys %{ $cfg_labels{RDEST} }) {
387      if (uc ($label) eq uc ($cfg_labels{RDEST}{$my_label})) {
388        $self->{RDEST}{$my_label} = $value;
389        next LINE;
390      }
391    }
392
393    # "USE" statements
394    if (uc ($label) eq uc ($cfg_labels{USE})) {
395      my $exists = grep {$_->cfg->src eq $value} @{ $self->{USE} };
396
397      # Initialise new Fcm::Extract object if not already exists
398      unless ($exists) {
399        my $extract = Fcm::Extract->new (
400          CONFIG    => $self->config,
401          CFG_SRC   => expand_tilde ($value),
402          EXTRACTED => 1,
403        );
404
405        $extract->decipher_cfg;
406        $extract->check_dest;
407        $extract->expand_cfg ();
408        push @{ $self->{USE} }, $extract;
409      }
410      next LINE;
411    }
412
413    # "Override" setting
414    if (uc ($label) eq uc ($cfg_labels{OVERRIDE})) {
415      $self->{OVERRIDE} = $value;
416      next LINE;
417    }
418
419    # "Mirror" command
420    if (uc ($label) eq uc ($cfg_labels{MIRROR})) {
421      $self->config->assign_setting (
422        LABELS => [qw/TOOL MIRROR/],
423        VALUE  => $value,
424      );
425      next LINE;
426    }
427
428    # Declared bld cfg entries
429    {
430      my $prefix = $cfg_labels{BDECLARE} . '::';
431
432      if (index (uc ($label), $prefix) == 0) {
433        my $name = substr $label, length ($prefix);
434
435        if ($name) {
436          push @{ $self->{BDECLARE} }, {LABEL => $name, VALUE => $value,};
437          next LINE;
438        }
439      }
440    }
441
442    # Repository, version and source directories
443    for my $my_label (qw/REPOS VERSION SRCDIR EXPSRCDIR/) {
444      my $prefix  = $cfg_labels{$my_label} . '::';
445
446      if (index (uc ($label), $prefix) == 0) {
447        my $name    = substr $label, length ($prefix);
448
449        # Detemine package and tag
450        my @names   = split /::/, $name;
451        my $tag     = pop @names;
452        my $pckroot = $names[0];
453        my $pck     = join '::', @names;
454
455        # Check that $tag and $pckroot are defined
456        last if not $tag;
457        last if not $pckroot;
458
459        # Check whether branch already exists
460        my @branches = grep {
461          $_->package eq $pckroot and $_->tag eq $tag
462        } @{ $self->{BRANCHES} };
463
464        my $branch   = undef;
465
466        if (@branches) { # If so, set $branch to point to existing branch
467          $branch = shift @branches;
468
469        } else {         # If not, create new branch
470          $branch = Fcm::ReposBranch->new (
471            CONFIG  => $self->config,
472            PACKAGE => $pckroot,
473            TAG     => $tag,
474          );
475
476          push @{ $self->{BRANCHES} }, $branch;
477        }
478
479        # Check package name for source directory declarations
480        if ($my_label eq 'SRCDIR' or $my_label eq 'EXPSRCDIR') {
481          if ($pck eq $pckroot and $value !~ m#^/#) {
482            # Sub-package name not set and source directory quoted as a relative
483            # path, determine package name from path name
484            my @subpck = File::Spec->splitdir ($value);
485            $pck       = join '::', ($pckroot, @subpck);
486          }
487        }
488
489        # Assign the value accordingly
490        if ($my_label eq 'REPOS') {          # Repository location
491          $branch->repos ($value);
492
493        } elsif ($my_label eq 'VERSION') {   # Version used
494          $branch->version ($value);
495
496        } elsif ($my_label eq 'SRCDIR') {    # Source directory used
497          $branch->dir ($pck, $value);
498
499        } elsif ($my_label eq 'EXPSRCDIR') { # Expandable source directory
500          $branch->expdir ($pck, $value);
501        }
502
503        next LINE;
504      }
505    }
506
507    # Label not recognised
508    w_report 'ERROR: ', $line->{SRC}, ': LINE ', $line->{NUMBER},
509             ': label "', $label, '" not recognised';
510    return;
511  }
512
513  return 1;
514}
515
516# ------------------------------------------------------------------------------
517# SYNOPSIS
518#   $ext->check_dest ();
519#
520# DESCRIPTION
521#   This method checks that the extract destionations are set correctly.
522# ------------------------------------------------------------------------------
523
524sub check_dest {
525  my $self = shift;
526
527  my %subdir  = %{ $self->config->setting ('DIR') };
528  my %cfgname = %{ $self->config->setting ('CFG_NAME') };
529
530  # Default destination settings
531  my $dest = $self->{DEST};
532  if ($dest->{ROOTDIR}) {
533    unless ($dest->{SRCDIR}) {   # Location of extracted source
534      $dest->{SRCDIR} = catfile $dest->{ROOTDIR}, $subdir{SRC};
535    }
536    unless ($dest->{CFGDIR}) {   # Location of configuration files
537      $dest->{CFGDIR} = catfile $dest->{ROOTDIR}, $subdir{CFG};
538    }
539    unless ($dest->{CACHEDIR}) { # Location of cache
540      $dest->{CACHEDIR} = catfile $dest->{ROOTDIR}, $subdir{CACHE};
541    }
542    unless ($dest->{BLD_CFG}) {  # Location of (output) bld cfg
543      $dest->{BLD_CFG} = catfile $dest->{CFGDIR}, $cfgname{BLD};
544    }
545    unless ($dest->{EXT_CFG}) {  # Location of (output) ext cfg
546      $dest->{EXT_CFG} = catfile $dest->{CFGDIR}, $cfgname{EXT};
547    }
548  } else {
549    w_report 'Error: ', $self->cfg->src,
550             ': destination root directory not set.';
551    return;
552  }
553
554  # Default remote destination settings
555  if ($self->{RDEST}{MACHINE}) {
556
557    # Use local logname as remote logname if it is not set
558    $self->{RDEST}{LOGNAME} = getlogin      unless $self->{RDEST}{LOGNAME};
559    $self->{RDEST}{LOGNAME} = $ENV{LOGNAME} unless $self->{RDEST}{LOGNAME};
560    $self->{RDEST}{LOGNAME} = $ENV{USER}    unless $self->{RDEST}{LOGNAME};
561
562    unless ($self->{RDEST}{LOGNAME}) {
563      w_report 'Error: ', $self->cfg->src,
564               ': cannot determine your remote logname.';
565      return;
566    }
567
568    # Make sure remote destination root directory is set
569    unless ($self->{RDEST}{ROOTDIR}) {
570      w_report 'Error: ', $self->cfg->src,
571               ': remote destination root directory not set.';
572      return;
573    }
574
575    # Make sure remote destination source directory is set
576    $self->{RDEST}{SRCDIR} = catfile $self->{RDEST}{ROOTDIR}, $subdir{SRC}
577      unless $self->{RDEST}{SRCDIR};
578
579    # Make sure remote destination configuration directory is set
580    $self->{RDEST}{CFGDIR} = catfile $self->{RDEST}{ROOTDIR}, $subdir{CFG}
581      unless $self->{RDEST}{CFGDIR};
582
583    # Make sure remote bld cfg is set
584    $self->{RDEST}{BLD_CFG} = catfile $self->{RDEST}{CFGDIR}, $cfgname{BLD}
585      unless $self->{RDEST}{BLD_CFG};
586
587    # Make sure remote ext cfg is set
588    $self->{RDEST}{EXT_CFG} = catfile $self->{RDEST}{CFGDIR}, $cfgname{EXT}
589      unless $self->{RDEST}{EXT_CFG};
590
591  }
592
593  return 1;
594}
595
596# ------------------------------------------------------------------------------
597# SYNOPSIS
598#   $ext->check_lock ();
599#
600# DESCRIPTION
601#   This method checks whether a lock is set in the current extract.
602# ------------------------------------------------------------------------------
603
604sub check_lock {
605  my $self = shift;
606
607  my $rootdir  = $self->{DEST}{ROOTDIR};
608  my $lock_ext = catfile ($rootdir, $self->config->setting (qw/MISC LOCK_EXT/));
609  my $lock_bld = catfile ($rootdir, $self->config->setting (qw/MISC LOCK_BLD/));
610
611  # Always throw error if extract lock exists
612  if (-e $lock_ext) {
613    w_report 'ERROR: extract lock file exists: ', $lock_ext, ',';
614    w_report '       an extract may be running at ', $rootdir, ', abort.';
615    return;
616  }
617
618  # Throw error if current object is not a "used" pre-extracted object and
619  # a build lock exists
620  if ((not $self->{EXTRACTED}) and -e $lock_bld) {
621    w_report 'ERROR: build lock file exists: ', $lock_bld, ',';
622    w_report '       a build may be running at ', $rootdir, ', abort.';
623    return;
624  }
625
626  # Check locks in inherited extract
627  for my $use (@{ $self->{USE} }) {
628    return unless $use->check_lock;
629  }
630
631  return 1;
632}
633
634# ------------------------------------------------------------------------------
635# SYNOPSIS
636#   $self->_set_lock ();
637#
638# DESCRIPTION
639#   This method sets a lock is set in the current extract.
640# ------------------------------------------------------------------------------
641
642sub _set_lock {
643  my $self = shift;
644
645  $self->{LOCK} = catfile (
646    $self->{DEST}{ROOTDIR}, $self->config->setting (qw/MISC LOCK_EXT/),
647  );
648
649  &touch_file ($self->{LOCK});
650
651  return 1;
652}
653
654# ------------------------------------------------------------------------------
655# SYNOPSIS
656#   $ext->expand_cfg ();
657#
658# DESCRIPTION
659#   This method expands the settings of the extract configuration.
660# ------------------------------------------------------------------------------
661
662sub expand_cfg {
663  my $self = shift;
664
665  # Establish a set of source directories from the "base repository"
666  my %base_branches = ();
667
668  # Inherit "base" set of source directories from re-used extracts
669  my @uses = @{ $self->{USE} };
670
671  for my $use (@uses) {
672    my @branches = $use->branches;
673
674    for my $branch (@branches) {
675      my $package              = $branch->package;
676      $base_branches{$package} = $branch unless exists $base_branches{$package};
677    }
678  }
679
680  for my $branch (@{ $self->{BRANCHES} }) {
681    # Expand URL keywords if necessary
682    if ($branch->repos) {
683      my $repos = expand_url_keyword (
684        URL => $branch->repos,
685        CFG => $self->config,
686      );
687      $branch->repos ($repos) if $repos ne $branch->repos;
688    }
689
690    # Check that repository type and version are set
691    if ($branch->repos and &is_url ($branch->repos)) {
692      $branch->type    ('svn')  unless $branch->type;
693      $branch->version ('head') unless $branch->version;
694
695    } else {
696      $branch->type    ('user') unless $branch->type;
697      $branch->version ('user') unless $branch->version;
698    }
699
700    $branch->expand_version_tag; # Work out revision number a version tag
701    $branch->expand_path;        # Expand relative path to full path
702    $branch->expand_all;         # Search sub-directories
703
704    my $package = $branch->package;
705
706    if (exists $base_branches{$package}) {
707      # A base branch for this package exists
708
709      # If current branch has no source directory, use the set provided by the
710      # base branch
711      my %dirs = $branch->dirs;
712      $branch->add_base_dirs ($base_branches{$package}) unless keys %dirs;
713
714    } else {
715      # This package does not yet have a base branch, set this branch as base
716      $base_branches{$package} = $branch;
717    }
718  }
719
720  return 1;
721}
722
723# ------------------------------------------------------------------------------
724# SYNOPSIS
725#   $self->_create_dest_dir ($full);
726#
727# DESCRIPTION
728#   This internal method (re-)creates all the destination directories if
729#   necessary. If $full is set to true, it removes existing directories/files
730#   in the destination directories.
731# ------------------------------------------------------------------------------
732
733sub _create_dest_dir {
734  my ($self, $full) = @_;
735
736  my $verbose = $self->config->verbose;
737
738  # Remove previous extract if "FULL" flag is set
739  if ($full) {
740    for my $my_label (qw/SRCDIR CACHEDIR/) {
741      my $dirname = $self->{DEST}{$my_label};
742
743      # If directory exists and writable by the user, remove it
744      if (-d $dirname and -w $dirname) {
745        print 'Remove directory: ', $dirname, "\n" if $verbose;
746        my $removed = rmtree $dirname;
747        w_report 'Warning: cannot remove old extract at: ', $dirname, '.'
748          if not $removed;
749      }
750    }
751  }
752
753  # Create extract destinations if necessary
754  for my $my_label (qw/ROOTDIR CACHEDIR CFGDIR SRCDIR/) {
755    my $dirname = $self->{DEST}{$my_label};
756
757    # Create directory if it does not already exist
758    if (not -d $dirname) {
759      print 'Make directory: ', $dirname, "\n" if $verbose > 1;
760      mkpath $dirname;
761    }
762
763    unless (-d $dirname and -w $dirname) {
764      w_report 'Error: cannot write to extract destination: ', $dirname, '.';
765      return;
766    }
767  }
768
769  return 1;
770}
771
772# ------------------------------------------------------------------------------
773# SYNOPSIS
774#   $ext->create_dir_stack (
775#     USE => $use, # Is this a pre-extracted configuration?
776#   );
777#
778# DESCRIPTION
779#   This method creates a hash of source directories to be processed. If the
780#   flag USE is set to true, the source directories are assumed processed and
781#   extracted.
782# ------------------------------------------------------------------------------
783
784sub create_dir_stack {
785  my $self = shift;
786  my %args = @_;
787  my $extracted = exists $args{USE} ? $args{USE} : undef;
788
789  # Inherit from USE ext cfg
790  if (@{ $self->{USE} } > 0) {
791    for my $use (@{ $self->{USE} }) {
792      $use->create_dir_stack (USE => 1);
793      my %use_srcdirs = $use->srcdirs;
794
795      while (my ($key, $value) = each %use_srcdirs) {
796        $self->{SRCDIRS}{$key} = $value;
797
798        # Re-set destination to current destination
799        my @path = split (/::/, $key);
800        $self->{SRCDIRS}{$key}{DEST} = catfile ($self->{DEST}{SRCDIR}, @path);
801      }
802    }
803  }
804
805  # Build stack from current ext cfg
806  for my $branch (@{ $self->{BRANCHES} }) {
807    my %branch_dirs = $branch->dirs;
808
809    for my $dir (keys %branch_dirs) {
810      # Check whether source directory is already in the list
811      if (not exists $self->{SRCDIRS}{$dir}) { # if not, create it
812        $self->{SRCDIRS}{$dir} = {
813          DEST  => catfile ($self->{DEST}{SRCDIR}, split (/::/, $dir)),
814          STACK => [],
815          FILES => {},
816        };
817      }
818
819      my $stack = $self->{SRCDIRS}{$dir}{STACK}; # copy reference
820
821      # Create a new layer in the input stack
822      my $layer = Fcm::SrcDirLayer->new (
823        CONFIG    => $self->config,
824        NAME      => $dir,
825        PACKAGE   => $branch->package,
826        TAG       => $branch->tag,
827        LOCATION  => $branch->dir ($dir),
828        REPOSROOT => $branch->repos,
829        VERSION   => $branch->version,
830        TYPE      => $branch->type,
831        EXTRACTED => $extracted ? $self->{SRCDIRS}{$dir}{DEST} : undef,
832      );
833
834      # Check whether layer is already in the stack
835      my $exist = grep {
836        $_->location eq $layer->location and $_->version  eq $layer->version;
837      } @{ $stack };
838
839      if (not $exist) {
840        # If not already exist, put layer into stack
841
842        # Note: user stack always comes last
843        if (! $layer->user and exists $stack->[-1] and $stack->[-1]->user) {
844          my $lastlayer = pop @{ $stack };
845          push @{ $stack }, $layer;
846          $layer = $lastlayer;
847        }
848
849        push @{ $stack }, $layer;
850
851      } elsif ($layer->user) {
852
853        # User layer already exists, overwrite it
854        $stack->[-1] = $layer;
855
856      }
857    }
858  }
859
860  # Read content of "commit cache" file if it exists
861  my $cachedir = $self->{DEST}{CACHEDIR};
862  my $cfgbase  = $self->config->setting (qw/CACHE EXTCONFIG/);
863  my $cfgfile  = catfile $cachedir, $cfgbase;
864  my %config_lines = ();
865  if (-r $cfgfile) {
866    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $cfgfile,);
867    $cfg->read_cfg;
868    my @lines = $cfg->lines;
869
870    for my $line (@lines) {
871      $config_lines{$line->{LABEL}} = $line->{VALUE};
872    }
873  }
874
875  my %new_config_lines;
876
877  # Compare each layer to base layer, discard unnecessary layers
878  for my $srcdir (keys %{ $self->{SRCDIRS} }) {
879    my @stack = ();
880
881    while (my $layer = shift @{ $self->{SRCDIRS}{$srcdir}{STACK} }) {
882      if ($layer->user) {
883        # User directory, check that the declared location exists
884        if (not -d $layer->location) {
885          w_report 'Error: declared source directory ', $layer->location,
886                   ' does not exists ';
887          return;
888        }
889
890        # Always override repository code
891        push @stack, $layer;
892
893      } else {
894        unless ($layer->extracted and $layer->commit) {
895
896          my $key = join '::', ($srcdir, $layer->location, $layer->version);
897
898          # See if commit version information is cached
899          if (keys %config_lines) {
900            if (exists $config_lines{$key}) {
901              $layer->commit ($config_lines{$key});
902            }
903          }
904
905          # Check source directory for commit version, if necessary
906          $layer->get_commit unless $layer->commit;
907          if (not $layer->commit) {
908            w_report 'Error: cannot determine the last changed revision of ',
909                     $layer->location;
910            return;
911          }
912
913          # Set cache directory for layer
914          my $tag_ver = $layer->tag . '__' . $layer->commit;
915          $layer->cachedir (catfile $cachedir, split (/::/, $srcdir), $tag_ver);
916
917          # New line in cache config file
918          $new_config_lines{$key} = $layer->commit;
919        }
920
921        # Push this layer in the stack:
922        # 1. it has a different version compared to the top layer
923        # 2. it is the top layer (base line code)
924        if (@stack > 0) {
925          push @stack, $layer if $layer->commit != $stack[0]->commit;
926
927        } else {
928          push @stack, $layer;
929        }
930
931      }
932    }
933
934    $self->{SRCDIRS}{$srcdir}{STACK} = \@stack;
935
936  }
937
938  # Write "commit cache" file
939  if (not $extracted) {
940    mkpath $cachedir if not -d $cachedir;
941    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config,);
942
943    while ((my $label, my $value) = each %new_config_lines) {
944      $cfg->add_line (LABEL => $label, VALUE => $value,);
945    }
946
947    $cfg->print_cfg ($cfgfile);
948  }
949
950  return 1;
951}
952
953# ------------------------------------------------------------------------------
954# SYNOPSIS
955#   $self->_extract_src ();
956#
957# DESCRIPTION
958#   This internal method performs the extract of the source directories and
959#   files if necessary.
960# ------------------------------------------------------------------------------
961
962sub _extract_src {
963  my $self = shift;
964
965  my $verbose = $self->config->verbose;
966  my %v_count = (
967    CREATED_DIRS    => 0,
968    IGNORED_SUBDIRS => 0,
969    UPDATED_FILES   => 0,
970    REMOVED_FILES   => 0,
971  );
972
973  my $cachedir = $self->{DEST}{CACHEDIR};
974
975  # Go through the "stack" of each source directory
976  # Extract the source directories/files if required
977
978  for my $srcdir (values %{ $self->{SRCDIRS} }) {
979
980    # Check if destionation exists and is not a directory
981    if (-f $srcdir->{DEST}) {
982      w_report $srcdir->{DEST},
983               ': destination exists and is not a directory, abort.';
984      return;
985    }
986
987    my %base_files   = (); # list of files in the base layer
988    my %used_files   = (); # keys = file basenames, values = layer reference
989    $srcdir->{FILES} = \%used_files;
990    my @destpath     = (); # search path for source directory destinations
991 
992    for my $layer (@{ $srcdir->{STACK} }) {
993      # Update the cache for each layer of the stack if necessary
994      $layer->update_cache unless $layer->extracted or -d $layer->localdir;
995
996      # Search path for extract destinations of this source directory
997      unshift @destpath, $layer->extracted
998        if $layer->extracted and not grep {$_ eq $layer->extracted} @destpath;
999 
1000      # Get list of files in the cache or local directory
1001      for my $file (($layer->get_files)) {
1002        if (exists $base_files{$file}) {
1003          # File exists in the base, compare current version with base version,
1004          # discard if not changed
1005          my $base_file = catfile $base_files{$file}->localdir, $file;
1006          my $used_file = catfile $used_files{$file}->localdir, $file;
1007          my $this_file = catfile $layer->localdir, $file;
1008
1009          if (compare ($base_file, $this_file)) { # Differs
1010            if ($base_files{$file} eq $used_files{$file}) {
1011              # Base and used are the same layer, use current layer
1012              $used_files{$file} = $layer;
1013
1014            } elsif (compare ($used_file, $this_file) == 0) {
1015              # Changes in used and this are the same, no update required
1016
1017              # Print a message at verbose mode 2 or above
1018              if ($verbose > 1) {
1019                print &_print_override_mesg (
1020                  FILE   => $file,
1021                  LAYER0 => $base_files{$file},
1022                  LAYER1 => $used_files{$file},
1023                  LAYER2 => $layer,
1024                );
1025                print '  Same modifications, use the source in URL 1.', "\n";
1026              }
1027
1028            } elsif ($self->{OVERRIDE}) {
1029              # Base and used are different, and used is not the same as this
1030              # Override mode, use current layer
1031
1032              # Print override mode message
1033              if ($verbose) {
1034                print &_print_override_mesg (
1035                  FILE   => $file,
1036                  LAYER0 => $base_files{$file},
1037                  LAYER1 => $used_files{$file},
1038                  LAYER2 => $layer,
1039                );
1040                print '  ', $file, ' in URL 2 overrides that in URL 1.', "\n";
1041              }
1042
1043              $used_files{$file} = $layer;
1044
1045            } else {
1046              # Base and used are different, and used is not the same as this
1047              # Non-override mode, fail the extract
1048              w_report &_print_override_mesg (
1049                FILE   => $file,
1050                LAYER0 => $base_files{$file},
1051                LAYER1 => $used_files{$file},
1052                LAYER2 => $layer,
1053              );
1054              w_report '  Override mode is false, file in URL 1 cannot ',
1055                       'override file in URL 2, abort.';
1056              return;
1057            }
1058          }
1059 
1060        } else {
1061          # The first time the file is found
1062          $base_files{$file} = $layer;
1063          $used_files{$file} = $layer;
1064        }
1065      }
1066    }
1067
1068    # Add current destination to the beginning of the destination search path
1069    unshift @destpath, $srcdir->{DEST} if -d $srcdir->{DEST};
1070
1071    for my $file (keys %used_files) {
1072      # Ignore sub-directories
1073      if (-d catfile $used_files{$file}->localdir, $file) {
1074        # Print diagnostic
1075        if ($verbose > 1) {
1076          print 'Ignore subdirectory: ', $file, "\n";
1077          print '                Src: ', $used_files{$file}->location;
1078          print '@', $used_files{$file}->version unless $used_files{$file}->user;
1079          print "\n";
1080        }
1081        $v_count{IGNORED_SUBDIRS}++;
1082        next;
1083      }
1084
1085      # Determine whether file has changed, compared with the destination
1086      my $diff = 1;
1087      for my $dir (@destpath) {
1088        my $old = catfile ($dir, $file);
1089
1090        if (-f $old) {
1091          my $new = catfile ($used_files{$file}->localdir, $file);
1092          $diff   = compare $old, $new;
1093          last;
1094        }
1095      }
1096
1097      if ($diff) { # copy if differs
1098        # Create extract destination, if required
1099        if (not -d $srcdir->{DEST}) {
1100          print 'Create directory: ', $srcdir->{DEST}, "\n" if $verbose > 1;
1101          my $mkdirs = mkpath $srcdir->{DEST};
1102
1103          if (! -d $srcdir->{DEST} or ! -w $srcdir->{DEST}) {
1104            w_report $srcdir->{DEST}, ': not a writable directory, abort.';
1105            return;
1106          }
1107
1108          $v_count{CREATED_DIRS} += $mkdirs;
1109        }
1110
1111        # Set up the copy command
1112        my @cmd = (
1113          'cp',
1114          catfile ($used_files{$file}->localdir, $file),
1115          $srcdir->{DEST},
1116        );
1117
1118        my $dest_file = catfile ($srcdir->{DEST}, $file);
1119
1120        # Print diagnostic
1121        if ($verbose > 1) {
1122          print 'Update: ', $dest_file, "\n";
1123          print '   Src: ', $used_files{$file}->location;
1124          print '@', $used_files{$file}->version unless $used_files{$file}->user;
1125          print "\n";
1126        }
1127
1128        # Remove old file if it exists
1129        unlink $dest_file if -f $dest_file;
1130
1131        # Execute the copy command
1132        &run_command (\@cmd, TIME => $self->config->verbose > 2);
1133
1134        $v_count{UPDATED_FILES}++;
1135      }
1136
1137    }
1138
1139    # Check that the destination directory does not contain any removed files
1140    opendir DIR, $srcdir->{DEST};
1141    my @dest_files = readdir DIR;
1142    closedir DIR;
1143
1144    while (my $file = shift @dest_files) {
1145      next if $file =~ /^\.\.?/;                   # ignore hidden files
1146      next if -d catfile ($srcdir->{DEST}, $file); # ignore sub-directories
1147
1148      # Check if the file exists in any of the versions
1149      my $exists = 0;
1150      for my $layer (@{ $srcdir->{STACK} }) {
1151        if (-f catfile ($layer->localdir, $file)) {
1152          $exists = 1;
1153          last;
1154        }
1155      }
1156
1157      # File exists in destination but not in any versions...
1158      if (not $exists) {
1159        my @cmd = (
1160          qw/rm -f/,
1161          catfile ($srcdir->{DEST}, $file),
1162        );
1163
1164        # Print diagnostic
1165        print 'Remove: ', catfile ($srcdir->{DEST}, $file), "\n"
1166          if $verbose > 1;
1167
1168        # Execute the command
1169        &run_command (\@cmd, TIME => $self->config->verbose > 2);
1170
1171        $v_count{REMOVED_FILES}++;
1172      }
1173    }
1174  }
1175
1176  if ($verbose) {
1177    my %v_label = (
1178      CREATED_DIRS    => 'Number of directories created    : ',
1179      IGNORED_SUBDIRS => 'Number of ignored sub-directories: ',
1180      UPDATED_FILES   => 'Number of updated files          : ',
1181      REMOVED_FILES   => 'Number of removed files          : ',
1182    );
1183    for my $key (qw/CREATED_DIRS IGNORED_SUBDIRS UPDATED_FILES REMOVED_FILES/) {
1184      print $v_label{$key}, $v_count{$key}, "\n" if $v_count{$key};
1185    }
1186  }
1187
1188  return 1;
1189}
1190
1191# ------------------------------------------------------------------------------
1192# SYNOPSIS
1193#   $string = _print_override_mesg (
1194#     FILE => $file,
1195#     LAYER0 => $layer0,
1196#     LAYER1 => $layer1,
1197#     LAYER2 => $layer2,
1198#   );
1199#
1200# DESCRIPTION
1201#   This internal method returns a string containing an override mode message.
1202#
1203# ARGUMENTS
1204#   FILE   - name of the source file
1205#   LAYER0 - base location
1206#   LAYER1 - source location overridden by LOC2
1207#   LAYER2 - source location overriding LOC1
1208# ------------------------------------------------------------------------------
1209
1210sub _print_override_mesg {
1211  my %args = @_;
1212
1213  my $string = $args{FILE};
1214  $string .= ': modified in both URL 1 and URL 2, relative to BASE:';
1215  $string .= "\n";
1216  $string .= '  BASE : ' . $args{LAYER0}->location;
1217  $string .= '@' . $args{LAYER0}->version unless $args{LAYER0}->user;
1218  $string .= "\n";
1219  $string .= '  URL 1: ' . $args{LAYER1}->location;
1220  $string .= '@' . $args{LAYER1}->version unless $args{LAYER1}->user;
1221  $string .= "\n";
1222  $string .= '  URL 2: ' . $args{LAYER2}->location;
1223  $string .= '@' . $args{LAYER2}->version unless $args{LAYER2}->user;
1224  $string .= "\n";
1225
1226  return $string;
1227}
1228
1229# ------------------------------------------------------------------------------
1230# SYNOPSIS
1231#   $self->_sort_bdeclare ();
1232#
1233# DESCRIPTION
1234#   This internal method sorts the declared build configuration entries,
1235#   filtering out repeated entries.
1236# ------------------------------------------------------------------------------
1237
1238sub _sort_bdeclare {
1239  my $self = shift;
1240
1241  # Get list of build configuration labels that can be declared multiple times
1242  my %cfg_labels   = %{ $self->config->setting ('CFG_LABEL') };
1243  my @cfg_keywords = split /,/, $self->config->setting ('CFG_KEYWORD');
1244  @cfg_keywords    = map {$cfg_labels{$_}} @cfg_keywords;
1245
1246  # Filter out repeated declarations
1247  my @bdeclares = ();
1248  for my $bdeclare (reverse @{ $self->{BDECLARE} }) {
1249    my $label = $bdeclare->{LABEL};
1250
1251    # Do not filter any declarations that can be declared multiple times
1252    my $unshift_ok = grep {
1253      uc ($label) eq $_ or index (uc ($label), $_ . '::') == 0;
1254    } @cfg_keywords;
1255    # @bdeclare contains nothing, last entry
1256    $unshift_ok    = 1 unless $unshift_ok or @bdeclares;
1257    # Check if a later entry already exists
1258    $unshift_ok    = 1
1259      unless $unshift_ok or grep {$_->{LABEL} eq $label} @bdeclares;
1260
1261    # Reconstruct array from bottom up
1262    unshift @bdeclares, $bdeclare if $unshift_ok;
1263  }
1264
1265  $self->{BDECLARE} = \@bdeclares;
1266
1267  return 1;
1268}
1269
1270# ------------------------------------------------------------------------------
1271# SYNOPSIS
1272#   $self->_write_ext_cfg ();
1273#
1274# DESCRIPTION
1275#   This internal method writes the expanded extract configuration file.
1276# ------------------------------------------------------------------------------
1277
1278sub _write_ext_cfg {
1279  my $self = shift;
1280
1281  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
1282  my %subdir     = %{ $self->config->setting ('DIR') };
1283  my %cfgname    = %{ $self->config->setting ('CFG_NAME') };
1284
1285  # Create new config file object and assign lines to it
1286  my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, TYPE => 'ext',);
1287
1288  # Set up config file header
1289  $cfg->add_header ();
1290
1291  # Re-use pre-extracted expanded ext cfg
1292  if (@{ $self->{USE} }) {
1293    $cfg->add_comment_block ('Other ext cfg');
1294
1295    for my $reuse (@{ $self->{USE} }) {
1296      my $rootdir = $reuse->dest ('ROOTDIR');
1297      my $ext_cfg = $reuse->cfg->src;
1298
1299      # Default location of build config file
1300      my $def_ext_cfg = catfile $rootdir, $subdir{CFG}, $cfgname{EXT};
1301
1302      $cfg->add_line (
1303        LABEL => $cfg_labels{USE},
1304        VALUE => $ext_cfg eq $def_ext_cfg ? $rootdir : $ext_cfg,
1305      );
1306    }
1307
1308    # Blank line
1309    $cfg->add_line;
1310  }
1311
1312  # Destination directories, config file, etc
1313  my $dest = $self->{DEST};
1314
1315  $cfg->add_comment_block ('Destination');
1316
1317  $cfg->add_line (
1318    LABEL => $cfg_labels{DEST}{ROOTDIR},
1319    VALUE => $dest->{ROOTDIR},
1320  );
1321
1322  for my $label (qw/CFG SRC CACHE/) {
1323    my $dir = $label . 'DIR';
1324
1325    if ($dest->{$dir} ne catfile $dest->{ROOTDIR}, $subdir{$label}) {
1326      $cfg->add_line (
1327        LABEL => $cfg_labels{DEST}{$dir},
1328        VALUE => $dest->{$dir},
1329      );
1330    }
1331  }
1332
1333  for my $name (qw/BLD EXT/) {
1334    my $label = $name . '_CFG';
1335
1336    if ($dest->{$label} ne catfile $dest->{CFGDIR}, $cfgname{$name}) {
1337      $cfg->add_line (
1338        LABEL => $cfg_labels{DEST}{$label},
1339        VALUE => $dest->{$label},
1340      );
1341    }
1342  }
1343
1344  # Blank line
1345  $cfg->add_line;
1346
1347  # Remote destination directories, config file, etc
1348  if ($self->{RDEST}{MACHINE}) {
1349    my $rdest = $self->{RDEST};
1350
1351    $cfg->add_comment_block ('Remote destination');
1352
1353    for my $label (qw/MACHINE LOGNAME ROOTDIR/) {
1354      $cfg->add_line (
1355        LABEL => $cfg_labels{RDEST}{$label},
1356        VALUE => $rdest->{$label},
1357      );
1358    }
1359
1360    for my $label (qw/CFG SRC/) {
1361      my $dir = $label . 'DIR';
1362      if ($rdest->{$dir} ne catfile $rdest->{ROOTDIR}, $subdir{$label}) {
1363        $cfg->add_line (
1364          LABEL => $cfg_labels{RDEST}{$dir},
1365          VALUE => $rdest->{$dir},
1366        );
1367      }
1368    }
1369
1370    for my $name (qw/BLD EXT/) {
1371      my $label = $name . '_CFG';
1372
1373      if ($rdest->{$label} ne catfile $rdest->{CFGDIR}, $cfgname{$name}) {
1374        $cfg->add_line (
1375          LABEL => $cfg_labels{RDEST}{$label},
1376          VALUE => $rdest->{$label},
1377        );
1378      }
1379    }
1380
1381    $cfg->add_line (
1382      LABEL => $cfg_labels{MIRROR},
1383      VALUE => $self->config->setting (qw/TOOL MIRROR/),
1384    );
1385
1386    # Blank line
1387    $cfg->add_line;
1388  }
1389
1390  if ($self->{OVERRIDE}) {
1391    $cfg->add_line (
1392      LABEL => $cfg_labels{OVERRIDE},
1393      VALUE => $self->{OVERRIDE} ? 1 : 0,
1394    );
1395    $cfg->add_line;
1396  }
1397
1398  # Source directories
1399  $cfg->add_comment_block ('Source directories');
1400
1401  # Set up lines in the ext cfg
1402  my @lines = ();
1403  for my $my_label (keys %{ $self->{SRCDIRS} }) {
1404    for my $layer (@{ $self->{SRCDIRS}{$my_label}{STACK} }) {
1405      next if $layer->extracted;
1406
1407      my $tag = $layer->package . '::' . $layer->tag;
1408
1409      # Repository
1410      my $exists = grep {
1411        $_->{LABEL} eq $cfg_labels{REPOS} . '::' . $tag;
1412      } @lines;
1413      push @lines, {
1414        LABEL   => $cfg_labels{REPOS} . '::' . $tag,
1415        VALUE   => $layer->reposroot,
1416      } if not $exists;
1417
1418      # Version
1419      $exists = grep {
1420        $_->{LABEL} eq $cfg_labels{VERSION} . '::' . $tag;
1421      } @lines;
1422      push @lines, {
1423        LABEL   => $cfg_labels{VERSION} . '::' . $tag,
1424        VALUE   => $layer->version,
1425      } unless $layer->user or $exists;
1426
1427      # Source directory
1428      my ($pcks, $path);
1429
1430      if ($layer->reposroot) {
1431        # Repository root declaration exists, print relative path
1432        if ($layer->location eq $layer->reposroot) {
1433          $path  = '';
1434
1435        } else {
1436          $path  = substr ($layer->location, length ($layer->reposroot) + 1);
1437        }
1438        my @pcks = split /::/, $my_label;
1439        shift @pcks;
1440
1441        if (join ('::', @pcks) eq join ('::', File::Spec->splitdir ($path))) {
1442          # Print top package name if relative path matches sub-package name
1443          $pcks = $layer->package;
1444
1445        } else {
1446          # Print full sub-package name otherwise
1447          $pcks = $my_label;
1448        }
1449
1450      } else {
1451        # No repository root declaration
1452        # Print full path and full sub-package name
1453        $path = $layer->location;
1454        $pcks = $my_label;
1455      }
1456
1457      my $length = $layer->reposroot ? length ($layer->reposroot) + 1 : 0;
1458      push @lines, {
1459        LABEL   => join ('::', ($cfg_labels{SRCDIR}, $pcks, $layer->tag)),
1460        VALUE   => $path,
1461      };
1462    }
1463  }
1464
1465  # Sort lines for specifying repository, version and source directories
1466  @lines = sort {
1467    my $rep_label = $cfg_labels{REPOS};
1468    my $ver_label = $cfg_labels{VERSION};
1469
1470    if ($a->{LABEL} =~ /^$rep_label/) {
1471
1472      # Repository labels
1473      if ($b->{LABEL} =~ /^$rep_label/) {
1474        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
1475      } else {
1476        -1;
1477      }
1478
1479    } elsif ($a->{LABEL} =~ /^$ver_label/) {
1480
1481      # Version labels
1482      if ($b->{LABEL} =~ /^$rep_label/) {
1483        1;
1484      } elsif ($b->{LABEL} =~ /^$ver_label/) {
1485        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
1486      } else {
1487        -1;
1488      }
1489    } else {
1490
1491      # Source directories labels
1492      if ($b->{LABEL} =~ /^(?:$rep_label|$ver_label)/) {
1493        1;
1494      } else {
1495        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
1496      }
1497
1498    }
1499  } @lines;
1500
1501  # Add lines for specifying repository, version and source directories
1502  while (my $line = shift @lines) {
1503    $cfg->add_line (
1504      LABEL => $line->{LABEL},
1505      VALUE => $line->{VALUE},
1506    );
1507  }
1508
1509  # Add declared bld cfg entries
1510  if (@{ $self->{BDECLARE} }) {
1511    # Blank line
1512    $cfg->add_line;
1513
1514    $cfg->add_comment_block ('Declared bld cfg entries');
1515    for my $bdeclare (@{ $self->{BDECLARE} }) {
1516      $cfg->add_line (
1517        LABEL => $cfg_labels{BDECLARE} . '::' . $bdeclare->{LABEL},
1518        VALUE => $bdeclare->{VALUE},
1519      );
1520    }
1521  }
1522
1523  # Print lines to config file
1524  $cfg->print_cfg ($self->{DEST}{EXT_CFG});
1525
1526  return 1;
1527
1528}
1529
1530# ------------------------------------------------------------------------------
1531# SYNOPSIS
1532#   $self->_write_bld_cfg ();
1533#
1534# DESCRIPTION
1535#   This internal method writes the build configuration file.
1536# ------------------------------------------------------------------------------
1537
1538sub _write_bld_cfg {
1539  my $self = shift;
1540
1541  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
1542  my %subdir     = %{ $self->config->setting ('DIR') };
1543  my %cfgname    = %{ $self->config->setting ('CFG_NAME') };
1544
1545  # Create new config file object and assign lines to it
1546  my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, TYPE => 'bld');
1547
1548  # Set up config file header
1549  $cfg->add_header ();
1550
1551  # Pre-compile source
1552  if (@{ $self->{USE} }) {
1553    $cfg->add_comment_block ('Pre-compile source');
1554
1555    for my $reuse (@{ $self->{USE} }) {
1556      my $rootdir;
1557      my $bld_cfg;
1558
1559      if ($self->{RDEST}{MACHINE}) {
1560        $rootdir = $reuse->rdest ('ROOTDIR');
1561        $bld_cfg = $reuse->rdest ('BLD_CFG');
1562      } else {
1563        $rootdir = $reuse->dest ('ROOTDIR');
1564        $bld_cfg = $reuse->dest ('BLD_CFG');
1565      }
1566
1567      # Default location of build config file
1568      my $def_bld_cfg = catfile $rootdir, $subdir{CFG}, $cfgname{BLD};
1569
1570      $cfg->add_line (
1571        LABEL => $cfg_labels{USE},
1572        VALUE => $bld_cfg eq $def_bld_cfg ? $rootdir : $bld_cfg,
1573      );
1574    }
1575
1576    # Blank line
1577    $cfg->add_line;
1578  }
1579
1580  # Add declared bld cfg entries
1581  if (@{ $self->{BDECLARE} }) {
1582    $cfg->add_comment_block ('Declared build options...');
1583
1584    my @bdeclares = sort {$a->{LABEL} cmp $b->{LABEL}} @{ $self->{BDECLARE} };
1585    for my $bdeclare (@bdeclares) {
1586      $cfg->add_line (
1587        LABEL => $bdeclare->{LABEL},
1588        VALUE => $bdeclare->{VALUE},
1589      );
1590    }
1591
1592    # Blank line
1593    $cfg->add_line;
1594  }
1595
1596  # Add source directories to config file
1597  $cfg->add_comment_block ('Project directory tree');
1598
1599  my $dest = $self->{RDEST}{MACHINE} ? $self->{RDEST} : $self->{DEST};
1600  $cfg->add_line (
1601    LABEL => $cfg_labels{DIR} . '::ROOT',
1602    VALUE => $dest->{ROOTDIR},
1603  );
1604  for my $label (qw/SRC CFG/) {
1605    my $dir = $label . 'DIR';
1606    if ($dest->{$dir} ne catfile $dest->{ROOTDIR}, $subdir{$label}) {
1607      $cfg->add_line (
1608        LABEL => $cfg_labels{DIR} . '::' . $label,
1609        VALUE => $dest->{$dir},
1610      );
1611    }
1612  }
1613
1614  # Blank line
1615  $cfg->add_line;
1616
1617  # Add source directories to config file
1618  $cfg->add_comment_block ('Source directories');
1619
1620  $cfg->add_line (LABEL => $cfg_labels{SEARCH_SRC}, VALUE => '0',);
1621  $cfg->add_line;
1622
1623  for my $srcdir (sort keys %{ $self->{SRCDIRS} }) {
1624
1625    if (-d $self->{SRCDIRS}{$srcdir}{DEST}) {
1626      # Check whether pre-extracted source exists
1627      my $pre_extracted = grep {
1628        $_->extracted;
1629      } @{ $self->{SRCDIRS}{$srcdir}{STACK} };
1630
1631      # Source directory
1632      my $dest = undef;
1633      if ($self->{RDEST}{MACHINE}) {
1634        my $base = substr $self->{SRCDIRS}{$srcdir}{DEST},
1635                          length ($self->{DEST}{SRCDIR}) + 1;
1636        $dest    = catfile $self->{RDEST}{SRCDIR}, $base;
1637      } else {
1638        $dest = $self->{SRCDIRS}{$srcdir}{DEST}
1639      }
1640
1641      # Source directory label
1642      my $label = join '::', ($cfg_labels{SRCDIR}, $srcdir);
1643
1644      $cfg->add_line (LABEL => $label, VALUE => $dest,)
1645    }
1646
1647  }
1648
1649  # Print lines to config file
1650  $cfg->print_cfg ($self->{DEST}{BLD_CFG});
1651
1652  return 1;
1653}
1654
1655# ------------------------------------------------------------------------------
1656# SYNOPSIS
1657#   $self->_mirror_extract ();
1658#
1659# DESCRIPTION
1660#   This internal method mirrors the current extract to a remote machine.
1661# ------------------------------------------------------------------------------
1662
1663sub _mirror_extract {
1664  my $self = shift;
1665
1666  # Needs mirroring only if remote machine is set
1667  return unless $self->{RDEST}{MACHINE};
1668
1669  my $verbose = $self->config->verbose;
1670
1671  my $mirror = $self->config->setting (qw/TOOL MIRROR/);
1672
1673  if ($mirror eq 'rdist') {
1674    # Use "rdist" to mirror extract
1675
1676    # Variable for "remote_logname@remote_machine"
1677    my $rhost = $self->{RDEST}{LOGNAME} . '@' . $self->{RDEST}{MACHINE};
1678
1679    # Print distfile content to temporary file
1680    my @distfile = ();
1681    for my $my_label (qw/BLD_CFG EXT_CFG SRCDIR/) {
1682      push @distfile, '( ' . $self->{DEST}{$my_label} . ' ) -> ' . $rhost . "\n";
1683      push @distfile, '  install ' . $self->{RDEST}{$my_label} . ';' . "\n";
1684    }
1685
1686    # Set up mirroring command (use "rdist" at the moment)
1687    my $command = 'rdist -R';
1688    $command   .= ' -q' unless $verbose > 1;
1689    $command   .= ' -f - 1>/dev/null';
1690
1691    # Diagnostic
1692    my $croak = 'Cannot execute "' . $command . '"';
1693    if ($verbose > 2) {
1694      print timestamp_command ($command, 'Start');
1695      print '  ', $_ for (@distfile);
1696    }
1697
1698    # Execute the mirroring command
1699    open COMMAND, '|-', $command or croak $croak, ' (', $!, '), abort';
1700    for my $line (@distfile) {
1701      print COMMAND $line;
1702    }
1703    close COMMAND or croak $croak, ' (', $?, '), abort';
1704
1705    # Diagnostic
1706    print timestamp_command ($command, 'End  ') if $verbose > 2;
1707
1708  } elsif ($mirror eq 'rsync') {
1709    # Use "rsync" to mirror extract
1710
1711    my $rsh = $self->config->setting (qw/TOOL REMOTE_SHELL/);
1712
1713    # Variable for "remote_logname@remote_machine"
1714    my $rhost = $self->{RDEST}{LOGNAME} . '@' . $self->{RDEST}{MACHINE};
1715
1716    for my $my_label (qw/BLD_CFG EXT_CFG SRCDIR/) {
1717      my $rdir = dirname $self->{RDEST}{$my_label}; # remote container directory
1718
1719      {
1720        # Create remote container directory with remote shell command
1721        my @command = (
1722          $rsh, $self->{RDEST}{MACHINE}, '-n', '-l', $self->{RDEST}{LOGNAME},
1723          qw/mkdir -p/, $rdir,
1724        );
1725
1726        # Execute command
1727        &run_command (\@command, TIME => $verbose > 2);
1728      }
1729
1730      {
1731        # Build the rsync command
1732        my @command = qw/rsync -a --exclude='.*' --delete-excluded/;
1733        push @command, '-v' if $verbose > 2;
1734        push @command, $self->{DEST}{$my_label};
1735        push @command, $rhost . ':' . $rdir;
1736
1737        # Execute command
1738        &run_command (\@command, TIME => $verbose > 2);
1739      }
1740    }
1741
1742  } else {
1743    w_report $mirror, ': unknown mirroring tool, abort.';
1744    return;
1745  }
1746
1747  return 1;
1748}
1749
1750# ------------------------------------------------------------------------------
1751
17521;
1753
1754__END__
Note: See TracBrowser for help on using the repository browser.