source: LMDZ6/branches/IPSLCM6.0.14/tools/fcm/lib/Fcm/Extract.pm @ 5456

Last change on this file since 5456 was 1578, checked in by jghattas, 13 years ago
  • Add fcm in LMDZ5/tools directory

It is no longer needed to have fcm in your environement PATH variable.
Now makelmdz_fcm takes by default this fcm. It is still possible to use
another fcm, using -fcm_path argument in makelmdz_fcm.
File size: 51.5 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    # Remove extracted source
741    if (-d $self->{DEST}{SRCDIR} and -w $self->{DEST}{SRCDIR}) {
742      print 'Remove directory: ', $self->{DEST}{SRCDIR}, "\n" if $verbose;
743      my $removed = rmtree $self->{DEST}{SRCDIR};
744      w_report 'WARNING: ', $self->{DEST}{SRCDIR}, ': cannot remove.'
745        if not $removed;
746    }
747
748    # Remove cache
749    my @files;
750    if (-d $self->{DEST}{CACHEDIR} and opendir DIR, $self->{DEST}{CACHEDIR}) {
751      @files = grep {$_ ne '.' and $_ ne '..'} readdir 'DIR';
752      closedir DIR;
753    }
754
755    for my $file (@files) {
756      my $path = File::Spec->catfile ($self->{DEST}{CACHEDIR}, $file);
757
758      next unless $file eq $self->config->setting (qw/CACHE EXTCONFIG/) or
759                  -d $path;
760
761      print 'Remove: ', $path, "\n" if $verbose;
762      my $removed = rmtree $path;
763      w_report 'WARNING: ', $path, ': cannot remove.' if not $removed;
764    }
765  }
766
767  # Create extract destinations if necessary
768  for my $my_label (qw/ROOTDIR CACHEDIR CFGDIR SRCDIR/) {
769    my $dirname = $self->{DEST}{$my_label};
770
771    # Create directory if it does not already exist
772    if (not -d $dirname) {
773      print 'Make directory: ', $dirname, "\n" if $verbose > 1;
774      mkpath $dirname;
775    }
776
777    unless (-d $dirname and -w $dirname) {
778      w_report 'ERROR: ', $dirname, ': cannot write to destination.';
779      return;
780    }
781  }
782
783  return 1;
784}
785
786# ------------------------------------------------------------------------------
787# SYNOPSIS
788#   $ext->create_dir_stack (
789#     USE => $use, # Is this a pre-extracted configuration?
790#   );
791#
792# DESCRIPTION
793#   This method creates a hash of source directories to be processed. If the
794#   flag USE is set to true, the source directories are assumed processed and
795#   extracted.
796# ------------------------------------------------------------------------------
797
798sub create_dir_stack {
799  my $self = shift;
800  my %args = @_;
801  my $extracted = exists $args{USE} ? $args{USE} : undef;
802
803  # Inherit from USE ext cfg
804  if (@{ $self->{USE} } > 0) {
805    for my $use (@{ $self->{USE} }) {
806      $use->create_dir_stack (USE => 1);
807      my %use_srcdirs = $use->srcdirs;
808
809      while (my ($key, $value) = each %use_srcdirs) {
810        $self->{SRCDIRS}{$key} = $value;
811
812        # Re-set destination to current destination
813        my @path = split (/::/, $key);
814        $self->{SRCDIRS}{$key}{DEST} = catfile ($self->{DEST}{SRCDIR}, @path);
815      }
816    }
817  }
818
819  # Build stack from current ext cfg
820  for my $branch (@{ $self->{BRANCHES} }) {
821    my %branch_dirs = $branch->dirs;
822
823    for my $dir (keys %branch_dirs) {
824      # Check whether source directory is already in the list
825      if (not exists $self->{SRCDIRS}{$dir}) { # if not, create it
826        $self->{SRCDIRS}{$dir} = {
827          DEST  => catfile ($self->{DEST}{SRCDIR}, split (/::/, $dir)),
828          STACK => [],
829          FILES => {},
830        };
831      }
832
833      my $stack = $self->{SRCDIRS}{$dir}{STACK}; # copy reference
834
835      # Create a new layer in the input stack
836      my $layer = Fcm::SrcDirLayer->new (
837        CONFIG    => $self->config,
838        NAME      => $dir,
839        PACKAGE   => $branch->package,
840        TAG       => $branch->tag,
841        LOCATION  => $branch->dir ($dir),
842        REPOSROOT => $branch->repos,
843        VERSION   => $branch->version,
844        TYPE      => $branch->type,
845        EXTRACTED => $extracted ? $self->{SRCDIRS}{$dir}{DEST} : undef,
846      );
847
848      # Check whether layer is already in the stack
849      my $exist = grep {
850        $_->location eq $layer->location and $_->version  eq $layer->version;
851      } @{ $stack };
852
853      if (not $exist) {
854        # If not already exist, put layer into stack
855
856        # Note: user stack always comes last
857        if (! $layer->user and exists $stack->[-1] and $stack->[-1]->user) {
858          my $lastlayer = pop @{ $stack };
859          push @{ $stack }, $layer;
860          $layer = $lastlayer;
861        }
862
863        push @{ $stack }, $layer;
864
865      } elsif ($layer->user) {
866
867        # User layer already exists, overwrite it
868        $stack->[-1] = $layer;
869
870      }
871    }
872  }
873
874  # Read content of "commit cache" file if it exists
875  my $cachedir = $self->{DEST}{CACHEDIR};
876  my $cfgbase  = $self->config->setting (qw/CACHE EXTCONFIG/);
877  my $cfgfile  = catfile $cachedir, $cfgbase;
878  my %config_lines = ();
879  if (-r $cfgfile) {
880    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $cfgfile,);
881    $cfg->read_cfg;
882    my @lines = $cfg->lines;
883
884    for my $line (@lines) {
885      $config_lines{$line->{LABEL}} = $line->{VALUE};
886    }
887  }
888
889  my %new_config_lines;
890
891  # Compare each layer to base layer, discard unnecessary layers
892  for my $srcdir (keys %{ $self->{SRCDIRS} }) {
893    my @stack = ();
894
895    while (my $layer = shift @{ $self->{SRCDIRS}{$srcdir}{STACK} }) {
896      if ($layer->user) {
897        # User directory, check that the declared location exists
898        if (not -d $layer->location) {
899          w_report 'Error: declared source directory ', $layer->location,
900                   ' does not exists ';
901          return;
902        }
903
904        # Always override repository code
905        push @stack, $layer;
906
907      } else {
908        unless ($layer->extracted and $layer->commit) {
909
910          my $key = join '::', ($srcdir, $layer->location, $layer->version);
911
912          # See if commit version information is cached
913          if (keys %config_lines) {
914            if (exists $config_lines{$key}) {
915              $layer->commit ($config_lines{$key});
916            }
917          }
918
919          # Check source directory for commit version, if necessary
920          $layer->get_commit unless $layer->commit;
921          if (not $layer->commit) {
922            w_report 'Error: cannot determine the last changed revision of ',
923                     $layer->location;
924            return;
925          }
926
927          # Set cache directory for layer
928          my $tag_ver = $layer->tag . '__' . $layer->commit;
929          $layer->cachedir (catfile $cachedir, split (/::/, $srcdir), $tag_ver);
930
931          # New line in cache config file
932          $new_config_lines{$key} = $layer->commit;
933        }
934
935        # Push this layer in the stack:
936        # 1. it has a different version compared to the top layer
937        # 2. it is the top layer (base line code)
938        if (@stack > 0) {
939          push @stack, $layer if $layer->commit != $stack[0]->commit;
940
941        } else {
942          push @stack, $layer;
943        }
944
945      }
946    }
947
948    $self->{SRCDIRS}{$srcdir}{STACK} = \@stack;
949
950  }
951
952  # Write "commit cache" file
953  if (not $extracted) {
954    mkpath $cachedir if not -d $cachedir;
955    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config,);
956
957    while ((my $label, my $value) = each %new_config_lines) {
958      $cfg->add_line (LABEL => $label, VALUE => $value,);
959    }
960
961    $cfg->print_cfg ($cfgfile);
962  }
963
964  return 1;
965}
966
967# ------------------------------------------------------------------------------
968# SYNOPSIS
969#   $self->_extract_src ();
970#
971# DESCRIPTION
972#   This internal method performs the extract of the source directories and
973#   files if necessary.
974# ------------------------------------------------------------------------------
975
976sub _extract_src {
977  my $self = shift;
978
979  my $verbose = $self->config->verbose;
980  my %v_count = (
981    CREATED_DIRS    => 0,
982    IGNORED_SUBDIRS => 0,
983    UPDATED_FILES   => 0,
984    REMOVED_FILES   => 0,
985  );
986
987  my $cachedir = $self->{DEST}{CACHEDIR};
988
989  # Go through the "stack" of each source directory
990  # Extract the source directories/files if required
991
992  for my $srcdir (values %{ $self->{SRCDIRS} }) {
993
994    # Check if destionation exists and is not a directory
995    if (-f $srcdir->{DEST}) {
996      w_report $srcdir->{DEST},
997               ': destination exists and is not a directory, abort.';
998      return;
999    }
1000
1001    my %base_files   = (); # list of files in the base layer
1002    my %used_files   = (); # keys = file basenames, values = layer reference
1003    $srcdir->{FILES} = \%used_files;
1004    my @destpath     = (); # search path for source directory destinations
1005 
1006    for my $layer (@{ $srcdir->{STACK} }) {
1007      # Update the cache for each layer of the stack if necessary
1008      $layer->update_cache unless $layer->extracted or -d $layer->localdir;
1009
1010      # Search path for extract destinations of this source directory
1011      unshift @destpath, $layer->extracted
1012        if $layer->extracted and not grep {$_ eq $layer->extracted} @destpath;
1013 
1014      # Get list of files in the cache or local directory
1015      for my $file (($layer->get_files)) {
1016        if (exists $base_files{$file}) {
1017          # File exists in the base, compare current version with base version,
1018          # discard if not changed
1019          my $base_file = catfile $base_files{$file}->localdir, $file;
1020          my $used_file = catfile $used_files{$file}->localdir, $file;
1021          my $this_file = catfile $layer->localdir, $file;
1022
1023          if (compare ($base_file, $this_file)) { # Differs
1024            if ($base_files{$file} eq $used_files{$file}) {
1025              # Base and used are the same layer, use current layer
1026              $used_files{$file} = $layer;
1027
1028            } elsif (compare ($used_file, $this_file) == 0) {
1029              # Changes in used and this are the same, no update required
1030
1031              # Print a message at verbose mode 2 or above
1032              if ($verbose > 1) {
1033                print &_print_override_mesg (
1034                  FILE   => $file,
1035                  LAYER0 => $base_files{$file},
1036                  LAYER1 => $used_files{$file},
1037                  LAYER2 => $layer,
1038                );
1039                print '  Same modifications, use the source in URL 1.', "\n";
1040              }
1041
1042            } elsif ($self->{OVERRIDE}) {
1043              # Base and used are different, and used is not the same as this
1044              # Override mode, use current layer
1045
1046              # Print override mode message
1047              if ($verbose) {
1048                print &_print_override_mesg (
1049                  FILE   => $file,
1050                  LAYER0 => $base_files{$file},
1051                  LAYER1 => $used_files{$file},
1052                  LAYER2 => $layer,
1053                );
1054                print '  ', $file, ' in URL 2 overrides that in URL 1.', "\n";
1055              }
1056
1057              $used_files{$file} = $layer;
1058
1059            } else {
1060              # Base and used are different, and used is not the same as this
1061              # Non-override mode, fail the extract
1062              w_report &_print_override_mesg (
1063                FILE   => $file,
1064                LAYER0 => $base_files{$file},
1065                LAYER1 => $used_files{$file},
1066                LAYER2 => $layer,
1067              );
1068              w_report '  Override mode is false, file in URL 1 cannot ',
1069                       'override file in URL 2, abort.';
1070              return;
1071            }
1072          }
1073 
1074        } else {
1075          # The first time the file is found
1076          $base_files{$file} = $layer;
1077          $used_files{$file} = $layer;
1078        }
1079      }
1080    }
1081
1082    # Add current destination to the beginning of the destination search path
1083    unshift @destpath, $srcdir->{DEST} if -d $srcdir->{DEST};
1084
1085    for my $file (keys %used_files) {
1086      # Ignore sub-directories
1087      if (-d catfile $used_files{$file}->localdir, $file) {
1088        # Print diagnostic
1089        if ($verbose > 1) {
1090          print 'Ignore subdirectory: ', $file, "\n";
1091          print '                Src: ', $used_files{$file}->location;
1092          print '@', $used_files{$file}->version unless $used_files{$file}->user;
1093          print "\n";
1094        }
1095        $v_count{IGNORED_SUBDIRS}++;
1096        next;
1097      }
1098
1099      # Determine whether file has changed, compared with the destination
1100      my $diff = 1;
1101      for my $dir (@destpath) {
1102        my $old = catfile ($dir, $file);
1103
1104        if (-f $old) {
1105          my $new = catfile ($used_files{$file}->localdir, $file);
1106          $diff   = compare $old, $new;
1107          last;
1108        }
1109      }
1110
1111      if ($diff) { # copy if differs
1112        # Create extract destination, if required
1113        if (not -d $srcdir->{DEST}) {
1114          print 'Create directory: ', $srcdir->{DEST}, "\n" if $verbose > 1;
1115          my $mkdirs = mkpath $srcdir->{DEST};
1116
1117          if (! -d $srcdir->{DEST} or ! -w $srcdir->{DEST}) {
1118            w_report $srcdir->{DEST}, ': not a writable directory, abort.';
1119            return;
1120          }
1121
1122          $v_count{CREATED_DIRS} += $mkdirs;
1123        }
1124
1125        # Set up the copy command
1126        my @cmd = (
1127          'cp',
1128          catfile ($used_files{$file}->localdir, $file),
1129          $srcdir->{DEST},
1130        );
1131
1132        my $dest_file = catfile ($srcdir->{DEST}, $file);
1133
1134        # Print diagnostic
1135        if ($verbose > 1) {
1136          print 'Update: ', $dest_file, "\n";
1137          print '   Src: ', $used_files{$file}->location;
1138          print '@', $used_files{$file}->version unless $used_files{$file}->user;
1139          print "\n";
1140        }
1141
1142        # Remove old file if it exists
1143        unlink $dest_file if -f $dest_file;
1144
1145        # Execute the copy command
1146        &run_command (\@cmd, TIME => $self->config->verbose > 2);
1147
1148        $v_count{UPDATED_FILES}++;
1149      }
1150
1151    }
1152
1153    # Check that the destination directory does not contain any removed files
1154    opendir DIR, $srcdir->{DEST};
1155    my @dest_files = readdir DIR;
1156    closedir DIR;
1157
1158    while (my $file = shift @dest_files) {
1159      next if $file =~ /^\.\.?/;                   # ignore hidden files
1160      next if -d catfile ($srcdir->{DEST}, $file); # ignore sub-directories
1161
1162      # Check if the file exists in any of the versions
1163      my $exists = 0;
1164      for my $layer (@{ $srcdir->{STACK} }) {
1165        if (-f catfile ($layer->localdir, $file)) {
1166          $exists = 1;
1167          last;
1168        }
1169      }
1170
1171      # File exists in destination but not in any versions...
1172      if (not $exists) {
1173        my @cmd = (
1174          qw/rm -f/,
1175          catfile ($srcdir->{DEST}, $file),
1176        );
1177
1178        # Print diagnostic
1179        print 'Remove: ', catfile ($srcdir->{DEST}, $file), "\n"
1180          if $verbose > 1;
1181
1182        # Execute the command
1183        &run_command (\@cmd, TIME => $self->config->verbose > 2);
1184
1185        $v_count{REMOVED_FILES}++;
1186      }
1187    }
1188  }
1189
1190  if ($verbose) {
1191    my %v_label = (
1192      CREATED_DIRS    => 'Number of directories created    : ',
1193      IGNORED_SUBDIRS => 'Number of ignored sub-directories: ',
1194      UPDATED_FILES   => 'Number of updated files          : ',
1195      REMOVED_FILES   => 'Number of removed files          : ',
1196    );
1197    for my $key (qw/CREATED_DIRS IGNORED_SUBDIRS UPDATED_FILES REMOVED_FILES/) {
1198      print $v_label{$key}, $v_count{$key}, "\n" if $v_count{$key};
1199    }
1200  }
1201
1202  return 1;
1203}
1204
1205# ------------------------------------------------------------------------------
1206# SYNOPSIS
1207#   $string = _print_override_mesg (
1208#     FILE => $file,
1209#     LAYER0 => $layer0,
1210#     LAYER1 => $layer1,
1211#     LAYER2 => $layer2,
1212#   );
1213#
1214# DESCRIPTION
1215#   This internal method returns a string containing an override mode message.
1216#
1217# ARGUMENTS
1218#   FILE   - name of the source file
1219#   LAYER0 - base location
1220#   LAYER1 - source location overridden by LOC2
1221#   LAYER2 - source location overriding LOC1
1222# ------------------------------------------------------------------------------
1223
1224sub _print_override_mesg {
1225  my %args = @_;
1226
1227  my $string = $args{FILE};
1228  $string .= ': modified in both URL 1 and URL 2, relative to BASE:';
1229  $string .= "\n";
1230  $string .= '  BASE : ' . $args{LAYER0}->location;
1231  $string .= '@' . $args{LAYER0}->version unless $args{LAYER0}->user;
1232  $string .= "\n";
1233  $string .= '  URL 1: ' . $args{LAYER1}->location;
1234  $string .= '@' . $args{LAYER1}->version unless $args{LAYER1}->user;
1235  $string .= "\n";
1236  $string .= '  URL 2: ' . $args{LAYER2}->location;
1237  $string .= '@' . $args{LAYER2}->version unless $args{LAYER2}->user;
1238  $string .= "\n";
1239
1240  return $string;
1241}
1242
1243# ------------------------------------------------------------------------------
1244# SYNOPSIS
1245#   $self->_sort_bdeclare ();
1246#
1247# DESCRIPTION
1248#   This internal method sorts the declared build configuration entries,
1249#   filtering out repeated entries.
1250# ------------------------------------------------------------------------------
1251
1252sub _sort_bdeclare {
1253  my $self = shift;
1254
1255  # Get list of build configuration labels that can be declared multiple times
1256  my %cfg_labels   = %{ $self->config->setting ('CFG_LABEL') };
1257  my @cfg_keywords = split /,/, $self->config->setting ('CFG_KEYWORD');
1258  @cfg_keywords    = map {$cfg_labels{$_}} @cfg_keywords;
1259
1260  # Filter out repeated declarations
1261  my @bdeclares = ();
1262  for my $bdeclare (reverse @{ $self->{BDECLARE} }) {
1263    my $label = $bdeclare->{LABEL};
1264
1265    # Do not filter any declarations that can be declared multiple times
1266    my $unshift_ok = grep {
1267      uc ($label) eq $_ or index (uc ($label), $_ . '::') == 0;
1268    } @cfg_keywords;
1269    # @bdeclare contains nothing, last entry
1270    $unshift_ok    = 1 unless $unshift_ok or @bdeclares;
1271    # Check if a later entry already exists
1272    $unshift_ok    = 1
1273      unless $unshift_ok or grep {$_->{LABEL} eq $label} @bdeclares;
1274
1275    # Reconstruct array from bottom up
1276    unshift @bdeclares, $bdeclare if $unshift_ok;
1277  }
1278
1279  $self->{BDECLARE} = \@bdeclares;
1280
1281  return 1;
1282}
1283
1284# ------------------------------------------------------------------------------
1285# SYNOPSIS
1286#   $self->_write_ext_cfg ();
1287#
1288# DESCRIPTION
1289#   This internal method writes the expanded extract configuration file.
1290# ------------------------------------------------------------------------------
1291
1292sub _write_ext_cfg {
1293  my $self = shift;
1294
1295  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
1296  my %subdir     = %{ $self->config->setting ('DIR') };
1297  my %cfgname    = %{ $self->config->setting ('CFG_NAME') };
1298
1299  # Create new config file object and assign lines to it
1300  my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, TYPE => 'ext',);
1301
1302  # Set up config file header
1303  $cfg->add_header ();
1304
1305  # Re-use pre-extracted expanded ext cfg
1306  if (@{ $self->{USE} }) {
1307    $cfg->add_comment_block ('Other ext cfg');
1308
1309    for my $reuse (@{ $self->{USE} }) {
1310      my $rootdir = $reuse->dest ('ROOTDIR');
1311      my $ext_cfg = $reuse->cfg->src;
1312
1313      # Default location of build config file
1314      my $def_ext_cfg = catfile $rootdir, $subdir{CFG}, $cfgname{EXT};
1315
1316      $cfg->add_line (
1317        LABEL => $cfg_labels{USE},
1318        VALUE => $ext_cfg eq $def_ext_cfg ? $rootdir : $ext_cfg,
1319      );
1320    }
1321
1322    # Blank line
1323    $cfg->add_line;
1324  }
1325
1326  # Destination directories, config file, etc
1327  my $dest = $self->{DEST};
1328
1329  $cfg->add_comment_block ('Destination');
1330
1331  $cfg->add_line (
1332    LABEL => $cfg_labels{DEST}{ROOTDIR},
1333    VALUE => $dest->{ROOTDIR},
1334  );
1335
1336  for my $label (qw/CFG SRC CACHE/) {
1337    my $dir = $label . 'DIR';
1338
1339    if ($dest->{$dir} ne catfile $dest->{ROOTDIR}, $subdir{$label}) {
1340      $cfg->add_line (
1341        LABEL => $cfg_labels{DEST}{$dir},
1342        VALUE => $dest->{$dir},
1343      );
1344    }
1345  }
1346
1347  for my $name (qw/BLD EXT/) {
1348    my $label = $name . '_CFG';
1349
1350    if ($dest->{$label} ne catfile $dest->{CFGDIR}, $cfgname{$name}) {
1351      $cfg->add_line (
1352        LABEL => $cfg_labels{DEST}{$label},
1353        VALUE => $dest->{$label},
1354      );
1355    }
1356  }
1357
1358  # Blank line
1359  $cfg->add_line;
1360
1361  # Remote destination directories, config file, etc
1362  if ($self->{RDEST}{MACHINE}) {
1363    my $rdest = $self->{RDEST};
1364
1365    $cfg->add_comment_block ('Remote destination');
1366
1367    for my $label (qw/MACHINE LOGNAME ROOTDIR/) {
1368      $cfg->add_line (
1369        LABEL => $cfg_labels{RDEST}{$label},
1370        VALUE => $rdest->{$label},
1371      );
1372    }
1373
1374    for my $label (qw/CFG SRC/) {
1375      my $dir = $label . 'DIR';
1376      if ($rdest->{$dir} ne catfile $rdest->{ROOTDIR}, $subdir{$label}) {
1377        $cfg->add_line (
1378          LABEL => $cfg_labels{RDEST}{$dir},
1379          VALUE => $rdest->{$dir},
1380        );
1381      }
1382    }
1383
1384    for my $name (qw/BLD EXT/) {
1385      my $label = $name . '_CFG';
1386
1387      if ($rdest->{$label} ne catfile $rdest->{CFGDIR}, $cfgname{$name}) {
1388        $cfg->add_line (
1389          LABEL => $cfg_labels{RDEST}{$label},
1390          VALUE => $rdest->{$label},
1391        );
1392      }
1393    }
1394
1395    $cfg->add_line (
1396      LABEL => $cfg_labels{MIRROR},
1397      VALUE => $self->config->setting (qw/TOOL MIRROR/),
1398    );
1399
1400    # Blank line
1401    $cfg->add_line;
1402  }
1403
1404  if ($self->{OVERRIDE}) {
1405    $cfg->add_line (
1406      LABEL => $cfg_labels{OVERRIDE},
1407      VALUE => $self->{OVERRIDE} ? 1 : 0,
1408    );
1409    $cfg->add_line;
1410  }
1411
1412  # Source directories
1413  $cfg->add_comment_block ('Source directories');
1414
1415  # Set up lines in the ext cfg
1416  my @lines = ();
1417  for my $my_label (keys %{ $self->{SRCDIRS} }) {
1418    for my $layer (@{ $self->{SRCDIRS}{$my_label}{STACK} }) {
1419      next if $layer->extracted;
1420
1421      my $tag = $layer->package . '::' . $layer->tag;
1422
1423      # Repository
1424      my $exists = grep {
1425        $_->{LABEL} eq $cfg_labels{REPOS} . '::' . $tag;
1426      } @lines;
1427      push @lines, {
1428        LABEL   => $cfg_labels{REPOS} . '::' . $tag,
1429        VALUE   => $layer->reposroot,
1430      } if not $exists;
1431
1432      # Version
1433      $exists = grep {
1434        $_->{LABEL} eq $cfg_labels{VERSION} . '::' . $tag;
1435      } @lines;
1436      push @lines, {
1437        LABEL   => $cfg_labels{VERSION} . '::' . $tag,
1438        VALUE   => $layer->version,
1439      } unless $layer->user or $exists;
1440
1441      # Source directory
1442      my ($pcks, $path);
1443
1444      if ($layer->reposroot) {
1445        # Repository root declaration exists, print relative path
1446        if ($layer->location eq $layer->reposroot) {
1447          $path  = '';
1448
1449        } else {
1450          $path  = substr ($layer->location, length ($layer->reposroot) + 1);
1451        }
1452        my @pcks = split /::/, $my_label;
1453        shift @pcks;
1454
1455        if (join ('::', @pcks) eq join ('::', File::Spec->splitdir ($path))) {
1456          # Print top package name if relative path matches sub-package name
1457          $pcks = $layer->package;
1458
1459        } else {
1460          # Print full sub-package name otherwise
1461          $pcks = $my_label;
1462        }
1463
1464      } else {
1465        # No repository root declaration
1466        # Print full path and full sub-package name
1467        $path = $layer->location;
1468        $pcks = $my_label;
1469      }
1470
1471      my $length = $layer->reposroot ? length ($layer->reposroot) + 1 : 0;
1472      push @lines, {
1473        LABEL   => join ('::', ($cfg_labels{SRCDIR}, $pcks, $layer->tag)),
1474        VALUE   => $path,
1475      };
1476    }
1477  }
1478
1479  # Sort lines for specifying repository, version and source directories
1480  @lines = sort {
1481    my $rep_label = $cfg_labels{REPOS};
1482    my $ver_label = $cfg_labels{VERSION};
1483
1484    if ($a->{LABEL} =~ /^$rep_label/) {
1485
1486      # Repository labels
1487      if ($b->{LABEL} =~ /^$rep_label/) {
1488        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
1489      } else {
1490        -1;
1491      }
1492
1493    } elsif ($a->{LABEL} =~ /^$ver_label/) {
1494
1495      # Version labels
1496      if ($b->{LABEL} =~ /^$rep_label/) {
1497        1;
1498      } elsif ($b->{LABEL} =~ /^$ver_label/) {
1499        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
1500      } else {
1501        -1;
1502      }
1503    } else {
1504
1505      # Source directories labels
1506      if ($b->{LABEL} =~ /^(?:$rep_label|$ver_label)/) {
1507        1;
1508      } else {
1509        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
1510      }
1511
1512    }
1513  } @lines;
1514
1515  # Add lines for specifying repository, version and source directories
1516  while (my $line = shift @lines) {
1517    $cfg->add_line (
1518      LABEL => $line->{LABEL},
1519      VALUE => $line->{VALUE},
1520    );
1521  }
1522
1523  # Add declared bld cfg entries
1524  if (@{ $self->{BDECLARE} }) {
1525    # Blank line
1526    $cfg->add_line;
1527
1528    $cfg->add_comment_block ('Declared bld cfg entries');
1529    for my $bdeclare (@{ $self->{BDECLARE} }) {
1530      $cfg->add_line (
1531        LABEL => $cfg_labels{BDECLARE} . '::' . $bdeclare->{LABEL},
1532        VALUE => $bdeclare->{VALUE},
1533      );
1534    }
1535  }
1536
1537  # Print lines to config file
1538  $cfg->print_cfg ($self->{DEST}{EXT_CFG});
1539
1540  return 1;
1541
1542}
1543
1544# ------------------------------------------------------------------------------
1545# SYNOPSIS
1546#   $self->_write_bld_cfg ();
1547#
1548# DESCRIPTION
1549#   This internal method writes the build configuration file.
1550# ------------------------------------------------------------------------------
1551
1552sub _write_bld_cfg {
1553  my $self = shift;
1554
1555  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
1556  my %subdir     = %{ $self->config->setting ('DIR') };
1557  my %cfgname    = %{ $self->config->setting ('CFG_NAME') };
1558
1559  # Create new config file object and assign lines to it
1560  my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, TYPE => 'bld');
1561
1562  # Set up config file header
1563  $cfg->add_header ();
1564
1565  # Pre-compile source
1566  if (@{ $self->{USE} }) {
1567    $cfg->add_comment_block ('Pre-compile source');
1568
1569    for my $reuse (@{ $self->{USE} }) {
1570      my $rootdir;
1571      my $bld_cfg;
1572
1573      if ($self->{RDEST}{MACHINE}) {
1574        $rootdir = $reuse->rdest ('ROOTDIR');
1575        $bld_cfg = $reuse->rdest ('BLD_CFG');
1576      } else {
1577        $rootdir = $reuse->dest ('ROOTDIR');
1578        $bld_cfg = $reuse->dest ('BLD_CFG');
1579      }
1580
1581      # Default location of build config file
1582      my $def_bld_cfg = catfile $rootdir, $subdir{CFG}, $cfgname{BLD};
1583
1584      $cfg->add_line (
1585        LABEL => $cfg_labels{USE},
1586        VALUE => $bld_cfg eq $def_bld_cfg ? $rootdir : $bld_cfg,
1587      );
1588    }
1589
1590    # Blank line
1591    $cfg->add_line;
1592  }
1593
1594  # Add declared bld cfg entries
1595  if (@{ $self->{BDECLARE} }) {
1596    $cfg->add_comment_block ('Declared build options...');
1597
1598    my @bdeclares = sort {$a->{LABEL} cmp $b->{LABEL}} @{ $self->{BDECLARE} };
1599    for my $bdeclare (@bdeclares) {
1600      $cfg->add_line (
1601        LABEL => $bdeclare->{LABEL},
1602        VALUE => $bdeclare->{VALUE},
1603      );
1604    }
1605
1606    # Blank line
1607    $cfg->add_line;
1608  }
1609
1610  # Add source directories to config file
1611  $cfg->add_comment_block ('Project directory tree');
1612
1613  my $dest = $self->{RDEST}{MACHINE} ? $self->{RDEST} : $self->{DEST};
1614  $cfg->add_line (
1615    LABEL => $cfg_labels{DIR} . '::ROOT',
1616    VALUE => $dest->{ROOTDIR},
1617  );
1618  for my $label (qw/SRC CFG/) {
1619    my $dir = $label . 'DIR';
1620    if ($dest->{$dir} ne catfile $dest->{ROOTDIR}, $subdir{$label}) {
1621      $cfg->add_line (
1622        LABEL => $cfg_labels{DIR} . '::' . $label,
1623        VALUE => $dest->{$dir},
1624      );
1625    }
1626  }
1627
1628  # Blank line
1629  $cfg->add_line;
1630
1631  # Add source directories to config file
1632  $cfg->add_comment_block ('Source directories');
1633
1634  $cfg->add_line (LABEL => $cfg_labels{SEARCH_SRC}, VALUE => '0',);
1635  $cfg->add_line;
1636
1637  for my $srcdir (sort keys %{ $self->{SRCDIRS} }) {
1638
1639    if (-d $self->{SRCDIRS}{$srcdir}{DEST}) {
1640      # Check whether pre-extracted source exists
1641      my $pre_extracted = grep {
1642        $_->extracted;
1643      } @{ $self->{SRCDIRS}{$srcdir}{STACK} };
1644
1645      # Source directory
1646      my $dest = undef;
1647      if ($self->{RDEST}{MACHINE}) {
1648        my $base = substr $self->{SRCDIRS}{$srcdir}{DEST},
1649                          length ($self->{DEST}{SRCDIR}) + 1;
1650        $dest    = catfile $self->{RDEST}{SRCDIR}, $base;
1651      } else {
1652        $dest = $self->{SRCDIRS}{$srcdir}{DEST}
1653      }
1654
1655      # Source directory label
1656      my $label = join '::', ($cfg_labels{SRCDIR}, $srcdir);
1657
1658      $cfg->add_line (LABEL => $label, VALUE => $dest,)
1659    }
1660
1661  }
1662
1663  # Print lines to config file
1664  $cfg->print_cfg ($self->{DEST}{BLD_CFG});
1665
1666  return 1;
1667}
1668
1669# ------------------------------------------------------------------------------
1670# SYNOPSIS
1671#   $self->_mirror_extract ();
1672#
1673# DESCRIPTION
1674#   This internal method mirrors the current extract to a remote machine.
1675# ------------------------------------------------------------------------------
1676
1677sub _mirror_extract {
1678  my $self = shift;
1679
1680  # Needs mirroring only if remote machine is set
1681  return unless $self->{RDEST}{MACHINE};
1682
1683  my $verbose = $self->config->verbose;
1684
1685  my $mirror = $self->config->setting (qw/TOOL MIRROR/);
1686
1687  if ($mirror eq 'rdist') {
1688    # Use "rdist" to mirror extract
1689
1690    # Variable for "remote_logname@remote_machine"
1691    my $rhost = $self->{RDEST}{LOGNAME} . '@' . $self->{RDEST}{MACHINE};
1692
1693    # Print distfile content to temporary file
1694    my @distfile = ();
1695    for my $my_label (qw/BLD_CFG EXT_CFG SRCDIR/) {
1696      push @distfile, '( ' . $self->{DEST}{$my_label} . ' ) -> ' . $rhost . "\n";
1697      push @distfile, '  install ' . $self->{RDEST}{$my_label} . ';' . "\n";
1698    }
1699
1700    # Set up mirroring command (use "rdist" at the moment)
1701    my $command = 'rdist -R';
1702    $command   .= ' -q' unless $verbose > 1;
1703    $command   .= ' -f - 1>/dev/null';
1704
1705    # Diagnostic
1706    my $croak = 'Cannot execute "' . $command . '"';
1707    if ($verbose > 2) {
1708      print timestamp_command ($command, 'Start');
1709      print '  ', $_ for (@distfile);
1710    }
1711
1712    # Execute the mirroring command
1713    open COMMAND, '|-', $command or croak $croak, ' (', $!, '), abort';
1714    for my $line (@distfile) {
1715      print COMMAND $line;
1716    }
1717    close COMMAND or croak $croak, ' (', $?, '), abort';
1718
1719    # Diagnostic
1720    print timestamp_command ($command, 'End  ') if $verbose > 2;
1721
1722  } elsif ($mirror eq 'rsync') {
1723    # Use "rsync" to mirror extract
1724
1725    my $rsh = $self->config->setting (qw/TOOL REMOTE_SHELL/);
1726
1727    # Variable for "remote_logname@remote_machine"
1728    my $rhost = $self->{RDEST}{LOGNAME} . '@' . $self->{RDEST}{MACHINE};
1729
1730    for my $my_label (qw/BLD_CFG EXT_CFG SRCDIR/) {
1731      my $rdir = dirname $self->{RDEST}{$my_label}; # remote container directory
1732
1733      {
1734        # Create remote container directory with remote shell command
1735        my @command = (
1736          $rsh, $self->{RDEST}{MACHINE}, '-n', '-l', $self->{RDEST}{LOGNAME},
1737          qw/mkdir -p/, $rdir,
1738        );
1739
1740        # Execute command
1741        &run_command (\@command, TIME => $verbose > 2);
1742      }
1743
1744      {
1745        # Build the rsync command
1746        my @command = qw/rsync -a --exclude='.*' --delete-excluded/;
1747        push @command, '-v' if $verbose > 2;
1748        push @command, $self->{DEST}{$my_label};
1749        push @command, $rhost . ':' . $rdir;
1750
1751        # Execute command
1752        &run_command (\@command, TIME => $verbose > 2);
1753      }
1754    }
1755
1756  } else {
1757    w_report $mirror, ': unknown mirroring tool, abort.';
1758    return;
1759  }
1760
1761  return 1;
1762}
1763
1764# ------------------------------------------------------------------------------
1765
17661;
1767
1768__END__
Note: See TracBrowser for help on using the repository browser.