source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM1/Build.pm @ 5407

Last change on this file since 5407 was 5129, checked in by abarral, 5 months ago

Re-add removed by mistake fcm
File size: 50.1 KB
Line 
1# ------------------------------------------------------------------------------
2# Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
3#
4# This file is part of FCM, tools for managing and building source code.
5#
6# FCM is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# FCM is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with FCM. If not, see <http://www.gnu.org/licenses/>.
18# ------------------------------------------------------------------------------
19# NAME
20#   FCM1::Build
21#
22# DESCRIPTION
23#   This is the top level class for the FCM build system.
24#
25# ------------------------------------------------------------------------------
26
27use strict;
28use warnings;
29
30package FCM1::Build;
31use base qw(FCM1::ConfigSystem);
32
33use Carp             qw{croak}                                       ;
34use Cwd              qw{cwd}                                         ;
35use FCM1::BuildSrc                                                   ;
36use FCM1::BuildTask                                                  ;
37use FCM1::Config                                                     ;
38use FCM1::Dest                                                       ;
39use FCM1::CfgLine                                                    ;
40use FCM1::Timer      qw{timestamp_command}                           ;
41use FCM1::Util       qw{expand_tilde run_command touch_file w_report};
42use File::Basename   qw{dirname}                                     ;
43use File::Spec                                                       ;
44use List::Util       qw{first}                                       ;
45use Text::ParseWords qw{shellwords}                                  ;
46
47# List of scalar property methods for this class
48my @scalar_properties = (
49  'name',    # name of this build
50  'target',  # targets of this build
51);
52
53# List of hash property methods for this class
54my @hash_properties = (
55  'srcpkg',      # source packages of this build
56  'dummysrcpkg', # dummy for handling package inheritance with file extension
57);
58
59# List of compare_setting_X methods
60my @compare_setting_methods = (
61  'compare_setting_bld_blockdata', # program executable blockdata dependency
62  'compare_setting_bld_dep',       # custom dependency setting
63  'compare_setting_bld_dep_excl',  # exclude dependency setting
64  'compare_setting_bld_dep_n',     # no dependency check
65  'compare_setting_bld_dep_pp',    # custom PP dependency setting
66  'compare_setting_bld_dep_exe',   # program executable extra dependency
67  'compare_setting_bld_exe_name',  # program executable rename
68  'compare_setting_bld_pp',        # PP flags
69  'compare_setting_infile_ext',    # input file extension
70  'compare_setting_outfile_ext',   # output file extension
71  'compare_setting_tool',          # build tool settings
72);
73
74my $DELIMITER_LIST = $FCM1::Config::DELIMITER_LIST;
75
76# ------------------------------------------------------------------------------
77# SYNOPSIS
78#   $obj = FCM1::Build->new;
79#
80# DESCRIPTION
81#   This method constructs a new instance of the FCM1::Build class.
82# ------------------------------------------------------------------------------
83
84sub new {
85  my $this  = shift;
86  my %args  = @_;
87  my $class = ref $this || $this;
88
89  my $self = FCM1::ConfigSystem->new (%args);
90
91  $self->{$_} = undef for (@scalar_properties);
92
93  $self->{$_} = {} for (@hash_properties);
94
95  bless $self, $class;
96
97  # List of sub-methods for parse_cfg
98  push @{ $self->cfg_methods }, (qw/target source tool dep misc/);
99
100  # Optional prefix in configuration declaration
101  $self->cfg_prefix ($self->setting (qw/CFG_LABEL BDECLARE/));
102
103  # System type
104  $self->type ('bld');
105
106  return $self;
107}
108
109# ------------------------------------------------------------------------------
110# SYNOPSIS
111#   $value = $obj->X;
112#   $obj->X ($value);
113#
114# DESCRIPTION
115#   Details of these properties are explained in @scalar_properties.
116# ------------------------------------------------------------------------------
117
118for my $name (@scalar_properties) {
119  no strict 'refs';
120
121  *$name = sub {
122    my $self = shift;
123
124    # Argument specified, set property to specified argument
125    if (@_) {
126      $self->{$name} = $_[0];
127    }
128
129    # Default value for property
130    if (not defined $self->{$name}) {
131      if ($name eq 'target') {
132        # Reference to an array
133        $self->{$name} = [];
134
135      } elsif ($name eq 'name') {
136        # Empty string
137        $self->{$name} = '';
138      }
139    }
140
141    return $self->{$name};
142  }
143}
144
145# ------------------------------------------------------------------------------
146# SYNOPSIS
147#   %hash = %{ $obj->X () };
148#   $obj->X (\%hash);
149#
150#   $value = $obj->X ($index);
151#   $obj->X ($index, $value);
152#
153# DESCRIPTION
154#   Details of these properties are explained in @hash_properties.
155#
156#   If no argument is set, this method returns a hash containing a list of
157#   objects. If an argument is set and it is a reference to a hash, the objects
158#   are replaced by the specified hash.
159#
160#   If a scalar argument is specified, this method returns a reference to an
161#   object, if the indexed object exists or undef if the indexed object does
162#   not exist. If a second argument is set, the $index element of the hash will
163#   be set to the value of the argument.
164# ------------------------------------------------------------------------------
165
166for my $name (@hash_properties) {
167  no strict 'refs';
168
169  *$name = sub {
170    my ($self, $arg1, $arg2) = @_;
171
172    # Ensure property is defined as a reference to a hash
173    $self->{$name} = {} if not defined ($self->{$name});
174
175    # Argument 1 can be a reference to a hash or a scalar index
176    my ($index, %hash);
177
178    if (defined $arg1) {
179      if (ref ($arg1) eq 'HASH') {
180        %hash = %$arg1;
181
182      } else {
183        $index = $arg1;
184      }
185    }
186
187    if (defined $index) {
188      # A scalar index is defined, set and/or return the value of an element
189      $self->{$name}{$index} = $arg2 if defined $arg2;
190
191      return (
192        exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
193      );
194
195    } else {
196      # A scalar index is not defined, set and/or return the hash
197      $self->{$name} = \%hash if defined $arg1;
198      return $self->{$name};
199    }
200  }
201}
202
203# ------------------------------------------------------------------------------
204# SYNOPSIS
205#   ($rc, $new_lines) = $self->X ($old_lines);
206#
207# DESCRIPTION
208#   This method compares current settings with those in the cache, where X is
209#   one of @compare_setting_methods.
210#
211#   If setting has changed:
212#   * For bld_blockdata, bld_dep_ext and bld_exe_name, it sets the re-generate
213#     make-rule flag to true.
214#   * For bld_dep_excl, in a standalone build, the method will remove the
215#     dependency cache files for affected sub-packages. It returns an error if
216#     the current build inherits from previous builds.
217#   * For bld_pp, it updates the PP setting for affected sub-packages.
218#   * For infile_ext, in a standalone build, the method will remove all the
219#     sub-package cache files and trigger a re-build by removing most
220#     sub-directories created by the previous build. It returns an error if the
221#     current build inherits from previous builds.
222#   * For outfile_ext, in a standalone build, the method will remove all the
223#     sub-package dependency cache files. It returns an error if the current
224#     build inherits from previous builds.
225#   * For tool, it updates the "flags" files for any changed tools.
226# ------------------------------------------------------------------------------
227
228for my $name (@compare_setting_methods) {
229  no strict 'refs';
230
231  *$name = sub {
232    my ($self, $old_lines) = @_;
233
234    (my $prefix = uc ($name)) =~ s/^COMPARE_SETTING_//;
235
236    my ($changed, $new_lines) =
237      $self->compare_setting_in_config ($prefix, $old_lines);
238
239    my $rc = scalar (keys %$changed);
240
241    if ($rc and $old_lines) {
242      $self->srcpkg ('')->is_updated (1);
243
244      if ($name =~ /^compare_setting_bld_dep(?:_excl|_n|_pp)?$/) {
245        # Mark affected packages as being updated
246        for my $key (keys %$changed) {
247          for my $pkg (values %{ $self->srcpkg }) {
248            next unless $pkg->is_in_package ($key);
249            $pkg->is_updated (1);
250          }
251        }
252
253      } elsif ($name eq 'compare_setting_bld_pp') {
254        # Mark affected packages as being updated
255        for my $key (keys %$changed) {
256          for my $pkg (values %{ $self->srcpkg }) {
257            next unless $pkg->is_in_package ($key);
258            next unless $self->srcpkg ($key)->is_type_any (
259              keys %{ $self->setting ('BLD_TYPE_DEP_PP') }
260            ); # Is a type requiring pre-processing
261
262            $pkg->is_updated (1);
263          }
264        }
265
266      } elsif ($name eq 'compare_setting_infile_ext') {
267        # Re-set input file type if necessary
268        for my $key (keys %$changed) {
269          for my $pkg (values %{ $self->srcpkg }) {
270            next unless $pkg->src and $pkg->ext and $key eq $pkg->ext;
271
272            $pkg->type (undef);
273          }
274        }
275
276        # Mark affected packages as being updated
277        for my $pkg (values %{ $self->srcpkg }) {
278          $pkg->is_updated (1);
279        }
280
281      } elsif ($name eq 'compare_setting_outfile_ext') {
282        # Mark affected packages as being updated
283        for my $pkg (values %{ $self->srcpkg }) {
284          $pkg->is_updated (1);
285        }
286
287      } elsif ($name eq 'compare_setting_tool') {
288        # Update the "flags" files for changed tools
289        for my $name (sort keys %$changed) {
290          my ($tool, @names) = split /__/, $name;
291          my $pkg  = join ('__', @names);
292          my @srcpkgs
293            = $self->srcpkg($pkg)      ? ($self->srcpkg($pkg))
294            : $self->dummysrcpkg($pkg) ? @{$self->dummysrcpkg($pkg)->children()}
295            :                            ()
296            ;
297          for my $srcpkg (@srcpkgs) {
298            my $file = File::Spec->catfile (
299              $self->dest->flagsdir, $srcpkg->flagsbase ($tool)
300            );
301            &touch_file ($file) or croak $file, ': cannot update, abort';
302
303            print $file, ': updated', "\n" if $self->verbose > 2;
304          }
305        }
306      }
307    }
308
309    return ($rc, $new_lines);
310  }
311}
312
313# ------------------------------------------------------------------------------
314# SYNOPSIS
315#   ($rc, $new_lines) = $self->compare_setting_dependency ($old_lines, $flag);
316#
317# DESCRIPTION
318#   This method uses the previous settings to determine the dependencies of
319#   current source files.
320# ------------------------------------------------------------------------------
321
322sub compare_setting_dependency {
323  my ($self, $old_lines, $flag) = @_;
324
325  my $prefix = $flag ? 'DEP_PP' : 'DEP';
326  my $method = $flag ? 'ppdep'  : 'dep';
327
328  my $rc = 0;
329  my $new_lines = [];
330
331  # Separate old lines
332  my %old;
333  if ($old_lines) {
334    for my $line (@$old_lines) {
335      next unless $line->label_starts_with ($prefix);
336      $old{$line->label_from_field (1)} = $line;
337    }
338  }
339
340  # Go through each source to see if the cache is up to date
341  my $count = 0;
342  my %mtime;
343  for my $srcpkg (values %{ $self->srcpkg }) {
344    next unless $srcpkg->cursrc and $srcpkg->type;
345
346    my $key = $srcpkg->pkgname;
347    my $out_of_date = $srcpkg->is_updated;
348
349    # Check modification time of cache and source file if not out of date
350    if (exists $old{$key}) {
351      if (not $out_of_date) {
352        $mtime{$old{$key}->src} = (stat ($old{$key}->src))[9]
353          if not exists ($mtime{$old{$key}->src});
354
355        $out_of_date = 1 if $mtime{$old{$key}->src} < $srcpkg->curmtime;
356      }
357    }
358    else {
359      $out_of_date = 1;
360    }
361
362    if ($out_of_date) {
363      # Re-scan dependency
364      $srcpkg->is_updated(1);
365      my ($source_is_read, $dep_hash_ref) = $srcpkg->get_dep($flag);
366      if ($source_is_read) {
367        $count++;
368      }
369      $srcpkg->$method($dep_hash_ref);
370      $rc = 1;
371    }
372    else {
373      # Use cached dependency
374      my ($progname, %hash) = split (
375        /$FCM1::Config::DELIMITER_PATTERN/, $old{$key}->value
376      );
377      $srcpkg->progname ($progname) if $progname and not $flag;
378      $srcpkg->$method (\%hash);
379    }
380
381    # New lines values: progname[::dependency-name::type][...]
382    my @value = ((defined $srcpkg->progname ? $srcpkg->progname : ''));
383    for my $name (sort keys %{ $srcpkg->$method }) {
384      push @value, $name, $srcpkg->$method ($name);
385    }
386
387    push @$new_lines, FCM1::CfgLine->new (
388      LABEL => $prefix . $FCM1::Config::DELIMITER . $key,
389      VALUE => join ($FCM1::Config::DELIMITER, @value),
390    );
391  }
392
393  print 'No. of file', ($count > 1 ? 's' : ''), ' scanned for',
394        ($flag ? ' PP': ''), ' dependency: ', $count, "\n"
395    if $self->verbose and $count;
396
397  return ($rc, $new_lines);
398}
399
400# ------------------------------------------------------------------------------
401# SYNOPSIS
402#   ($rc, $new_lines) = $self->compare_setting_srcpkg ($old_lines);
403#
404# DESCRIPTION
405#   This method uses the previous settings to determine the type of current
406#   source files.
407# ------------------------------------------------------------------------------
408
409sub compare_setting_srcpkg {
410  my ($self, $old_lines) = @_;
411
412  my $prefix = 'SRCPKG';
413
414  # Get relevant items from old lines, stripping out $prefix
415  my %old;
416  if ($old_lines) {
417    for my $line (@$old_lines) {
418      next unless $line->label_starts_with ($prefix);
419      $old{$line->label_from_field (1)} = $line;
420    }
421  }
422
423  # Check for change, use previous setting if exist
424  my $out_of_date = 0;
425  my %mtime;
426  for my $key (keys %{ $self->srcpkg }) {
427    if (exists $old{$key}) {
428      next unless $self->srcpkg ($key)->cursrc;
429
430      my $type = defined $self->setting ('BLD_TYPE', $key)
431                 ? $self->setting ('BLD_TYPE', $key) : $old{$key}->value;
432
433      $self->srcpkg ($key)->type ($type);
434
435      if ($type ne $old{$key}->value) {
436        $self->srcpkg ($key)->is_updated (1);
437        $out_of_date = 1;
438      }
439
440      if (not $self->srcpkg ($key)->is_updated) {
441        $mtime{$old{$key}->src} = (stat ($old{$key}->src))[9]
442          if not exists ($mtime{$old{$key}->src});
443
444        $self->srcpkg ($key)->is_updated (1)
445          if $mtime{$old{$key}->src} < $self->srcpkg ($key)->curmtime;
446      }
447
448    } else {
449      $self->srcpkg ($key)->is_updated (1);
450      $out_of_date = 1;
451    }
452  }
453
454  # Check for deleted keys
455  for my $key (keys %old) {
456    next if $self->srcpkg ($key);
457
458    $out_of_date = 1;
459  }
460
461  # Return reference to an array of new lines
462  my $new_lines = [];
463  for my $key (keys %{ $self->srcpkg }) {
464    push @$new_lines, FCM1::CfgLine->new (
465      LABEL => $prefix . $FCM1::Config::DELIMITER . $key,
466      VALUE => $self->srcpkg ($key)->type,
467    );
468  }
469
470  return ($out_of_date, $new_lines);
471}
472
473# ------------------------------------------------------------------------------
474# SYNOPSIS
475#   ($rc, $new_lines) = $self->compare_setting_target ($old_lines);
476#
477# DESCRIPTION
478#   This method compare the previous target settings with current ones.
479# ------------------------------------------------------------------------------
480
481sub compare_setting_target {
482  my ($self, $old_lines) = @_;
483
484  my $prefix = 'TARGET';
485  my $old;
486  if ($old_lines) {
487    for my $line (@$old_lines) {
488      next unless $line->label_starts_with ($prefix);
489      $old = $line->value;
490      last;
491    }
492  }
493
494  my $new = join (' ', sort @{ $self->target });
495
496  return (
497    (defined ($old) ? $old ne $new : 1),
498    [FCM1::CfgLine->new (LABEL => $prefix, VALUE => $new)],
499  );
500}
501
502# ------------------------------------------------------------------------------
503# SYNOPSIS
504#   $rc = $self->invoke_fortran_interface_generator ();
505#
506# DESCRIPTION
507#   This method invokes the Fortran interface generator for all Fortran free
508#   format source files. It returns true on success.
509# ------------------------------------------------------------------------------
510
511sub invoke_fortran_interface_generator {
512  my $self = shift;
513
514  my $pdoneext = $self->setting (qw/OUTFILE_EXT PDONE/);
515
516  # Set up build task to generate interface files for all selected Fortran 9x
517  # sources
518  my %task = ();
519  SRC_FILE:
520  for my $srcfile (values %{ $self->srcpkg }) {
521    if (!defined($srcfile->interfacebase())) {
522      next SRC_FILE;
523    }
524    my $target  = $srcfile->interfacebase . $pdoneext;
525
526    $task{$target} = FCM1::BuildTask->new (
527      TARGET     => $target,
528      TARGETPATH => $self->dest->donepath,
529      SRCFILE    => $srcfile,
530      DEPENDENCY => [$srcfile->flagsbase ('GENINTERFACE')],
531      ACTIONTYPE => 'GENINTERFACE',
532    );
533
534    # Set up build tasks for each source file/package flags file for interface
535    # generator tool
536    for my $i (1 .. @{ $srcfile->pkgnames }) {
537      my $target = $srcfile->flagsbase ('GENINTERFACE', -$i);
538      my $depend = $i < @{ $srcfile->pkgnames }
539                   ? $srcfile->flagsbase ('GENINTERFACE', -$i - 1)
540                   : undef;
541
542      $task{$target} = FCM1::BuildTask->new (
543        TARGET     => $target,
544        TARGETPATH => $self->dest->flagspath,
545        DEPENDENCY => [defined ($depend) ? $depend : ()],
546        ACTIONTYPE => 'UPDATE',
547      ) if not exists $task{$target};
548    }
549  }
550
551  # Set up build task to update the flags file for interface generator tool
552  $task{$self->srcpkg ('')->flagsbase ('GENINTERFACE')} = FCM1::BuildTask->new (
553    TARGET     => $self->srcpkg ('')->flagsbase ('GENINTERFACE'),
554    TARGETPATH => $self->dest->flagspath,
555    ACTIONTYPE => 'UPDATE',
556  );
557
558  my $count = 0;
559
560  # Performs task
561  for my $task (values %task) {
562    next unless $task->actiontype eq 'GENINTERFACE';
563
564    my $rc = $task->action (TASKLIST => \%task);
565    $count++ if $rc;
566  }
567
568  print 'No. of generated Fortran interface', ($count > 1 ? 's' : ''), ': ',
569        $count, "\n"
570    if $self->verbose and $count;
571
572  return 1;
573}
574
575# ------------------------------------------------------------------------------
576# SYNOPSIS
577#   $rc = $self->invoke_make (%args);
578#
579# DESCRIPTION
580#   This method invokes the make stage of the build system. It returns true on
581#   success.
582#
583# ARGUMENTS
584#   ARCHIVE - If set to "true", invoke the "archive" mode. Most build files and
585#             directories created by this build will be archived using the
586#             "tar" command.  If not set, the default is not to invoke the
587#             "archive" mode.
588#   JOBS    - Specify number of jobs that can be handled by "make". If set, the
589#             value must be a natural integer. If not set, the default value is
590#             1 (i.e.  run "make" in serial mode).
591#   TARGETS - Specify targets to be built. If set, these targets will be built
592#             instead of the ones specified in the build configuration file.
593# ------------------------------------------------------------------------------
594
595sub invoke_make {
596  my ($self, %args) = @_;
597  $args{TARGETS} ||= ['all'];
598  $args{JOBS}    ||= 1;
599  my @command = (
600    $self->setting(qw/TOOL MAKE/),
601    shellwords($self->setting(qw/TOOL MAKEFLAGS/)),
602    # -f Makefile
603    ($self->setting(qw/TOOL MAKE_FILE/), $self->dest()->bldmakefile()),
604    # -j N
605    ($args{JOBS} ? ($self->setting(qw/TOOL MAKE_JOB/), $args{JOBS}) : ()),
606    # -s
607    ($self->verbose() < 3 ? $self->setting(qw/TOOL MAKE_SILENT/) : ()),
608    @{$args{TARGETS}}
609  );
610  my $old_cwd = $self->_chdir($self->dest()->rootdir());
611  run_command(
612    \@command, ERROR => 'warn', RC => \my($code), TIME => $self->verbose() >= 3,
613  );
614  $self->_chdir($old_cwd);
615
616  my $rc = !$code;
617  if ($rc && $args{ARCHIVE}) {
618    $rc = $self->dest()->archive();
619  }
620  $rc &&= $self->dest()->create_bldrunenvsh();
621  while (my ($key, $source) = each(%{$self->srcpkg()})) {
622    $rc &&= defined($source->write_lib_dep_excl());
623  }
624  return $rc;
625}
626
627# ------------------------------------------------------------------------------
628# SYNOPSIS
629#   $rc = $self->invoke_pre_process ();
630#
631# DESCRIPTION
632#   This method invokes the pre-process stage of the build system. It
633#   returns true on success.
634# ------------------------------------------------------------------------------
635
636sub invoke_pre_process {
637  my $self = shift;
638   
639  # Check whether pre-processing is necessary
640  my $invoke = 0;
641  for (values %{ $self->srcpkg }) {
642    next unless $_->get_setting ('BLD_PP');
643    $invoke = 1;
644    last;
645  }
646  return 1 unless $invoke;
647
648  # Scan header dependency
649  my $rc = $self->compare_setting (
650    METHOD_LIST => ['compare_setting_dependency'],
651    METHOD_ARGS => ['BLD_TYPE_DEP_PP'],
652    CACHEBASE   => $self->setting ('CACHE_DEP_PP'),
653  );
654
655  return $rc if not $rc;
656
657  my %task     = ();
658  my $pdoneext = $self->setting (qw/OUTFILE_EXT PDONE/);
659
660  # Set up tasks for each source file
661  for my $srcfile (values %{ $self->srcpkg }) {
662    if ($srcfile->is_type_all (qw/CPP INCLUDE/)) {
663      # Set up a copy build task for each include file
664      $task{$srcfile->base} = FCM1::BuildTask->new (
665        TARGET     => $srcfile->base,
666        TARGETPATH => $self->dest->incpath,
667        SRCFILE    => $srcfile,
668        DEPENDENCY => [keys %{ $srcfile->ppdep }],
669        ACTIONTYPE => 'COPY',
670      );
671
672    } elsif ($srcfile->lang ('TOOL_SRC_PP')) {
673      next unless $srcfile->get_setting ('BLD_PP');
674
675      # Set up a PP build task for each source file
676      my $target = $srcfile->base . $pdoneext;
677
678      # Issue warning for duplicated tasks
679      if (exists $task{$target}) {
680        w_report 'WARNING: ', $target, ': unable to create task for: ',
681                 $srcfile->src, ': task already exists for: ',
682                 $task{$target}->srcfile->src;
683        next;
684      }
685
686      $task{$target} = FCM1::BuildTask->new (
687        TARGET     => $target,
688        TARGETPATH => $self->dest->donepath,
689        SRCFILE    => $srcfile,
690        DEPENDENCY => [$srcfile->flagsbase ('PPKEYS'), keys %{ $srcfile->ppdep }],
691        ACTIONTYPE => 'PP',
692      );
693
694      # Set up update ppkeys/flags build tasks for each source file/package
695      my $ppkeys = $self->setting (
696        'TOOL_SRC_PP', $srcfile->lang ('TOOL_SRC_PP'), 'PPKEYS'
697      );
698
699      for my $i (1 .. @{ $srcfile->pkgnames }) {
700        my $target = $srcfile->flagsbase ($ppkeys, -$i);
701        my $depend = $i < @{ $srcfile->pkgnames }
702                     ? $srcfile->flagsbase ($ppkeys, -$i - 1)
703                     : undef;
704
705        $task{$target} = FCM1::BuildTask->new (
706          TARGET     => $target,
707          TARGETPATH => $self->dest->flagspath,
708          DEPENDENCY => [defined ($depend) ? $depend : ()],
709          ACTIONTYPE => 'UPDATE',
710        ) if not exists $task{$target};
711      }
712    }
713  }
714
715  # Set up update global ppkeys build tasks
716  for my $lang (keys %{ $self->setting ('TOOL_SRC_PP') }) {
717    my $target = $self->srcpkg ('')->flagsbase (
718      $self->setting ('TOOL_SRC_PP', $lang, 'PPKEYS')
719    );
720
721    $task{$target} = FCM1::BuildTask->new (
722      TARGET     => $target,
723      TARGETPATH => $self->dest->flagspath,
724      ACTIONTYPE => 'UPDATE',
725    );
726  }
727
728  # Build all PP tasks
729  my $count = 0;
730  for my $task (values %task) {
731    next unless $task->actiontype eq 'PP';
732
733    my $rc = $task->action (TASKLIST => \%task);
734    $task->srcfile->is_updated ($rc);
735    $count++ if $rc;
736  }
737
738  print 'No. of pre-processed file', ($count > 1 ? 's' : ''), ': ', $count, "\n"
739    if $self->verbose and $count;
740
741  return 1;
742}
743
744# ------------------------------------------------------------------------------
745# SYNOPSIS
746#   $rc = $self->invoke_scan_dependency ();
747#
748# DESCRIPTION
749#   This method invokes the scan dependency stage of the build system. It
750#   returns true on success.
751# ------------------------------------------------------------------------------
752
753sub invoke_scan_dependency {
754  my $self = shift;
755
756  # Scan/retrieve dependency
757  # ----------------------------------------------------------------------------
758  my $rc = $self->compare_setting (
759    METHOD_LIST => ['compare_setting_dependency'],
760    CACHEBASE   => $self->setting ('CACHE_DEP'),
761  );
762
763  # Check whether make file is out of date
764  # ----------------------------------------------------------------------------
765  my $out_of_date = ! -f $self->dest->bldmakefile;
766
767  if ($rc and not $out_of_date) {
768    for (qw/CACHE CACHE_DEP/) {
769      my $cache_mtime = (stat (File::Spec->catfile (
770        $self->dest->cachedir, $self->setting ($_),
771      )))[9];
772      my $mfile_mtime = (stat ($self->dest->bldmakefile))[9];
773
774      next if not defined $cache_mtime;
775      next if $cache_mtime < $mfile_mtime;
776      $out_of_date = 1;
777      last;
778    }
779  }
780
781  if ($rc and not $out_of_date) {
782    for (values %{ $self->srcpkg }) {
783      next unless $_->is_updated;
784      $out_of_date = 1;
785      last;
786    }
787  }
788
789  if ($rc and $out_of_date) {
790    # Write Makefile
791    # --------------------------------------------------------------------------
792    # Register non-word package name
793    my $unusual = 0;
794    for my $key (sort keys %{ $self->srcpkg }) {
795      next if $self->srcpkg ($key)->src;
796      next if $key =~ /^\w*$/;
797
798      $self->setting (
799        ['FCM_PCK_OBJECTS', $key], 'FCM_PCK_OBJECTS' . $unusual++,
800      );
801    }
802
803    # Write different parts in the Makefile
804    my $makefile = '# Automatic Makefile' . "\n\n";
805    $makefile .= 'FCM_BLD_NAME = ' . $self->name . "\n" if $self->name;
806    $makefile .= 'FCM_BLD_CFG = ' . $self->cfg->actual_src . "\n";
807    $makefile .= 'export FCM_VERBOSE ?= ' . $self->verbose . "\n\n";
808    $makefile .= "export OBJECTS\n";
809    $makefile .= $self->dest->write_rules;
810    $makefile .= $self->_write_makefile_perl5lib;
811    $makefile .= $self->_write_makefile_tool;
812    $makefile .= $self->_write_makefile_vpath;
813    $makefile .= $self->_write_makefile_target;
814
815    # Write rules for each source package
816    # Ensure that container packages come before files - this allows $(OBJECTS)
817    # and its dependent variables to expand correctly
818    my @srcpkg = sort {
819      if ($self->srcpkg ($a)->libbase and $self->srcpkg ($b)->libbase) {
820        $b cmp $a;
821
822      } elsif ($self->srcpkg ($a)->libbase) {
823        -1;
824
825      } elsif ($self->srcpkg ($b)->libbase) {
826        1;
827
828      } else {
829        $a cmp $b;
830      }
831    } keys %{ $self->srcpkg };
832
833    for (@srcpkg) {
834      $makefile .= $self->srcpkg ($_)->write_rules if $self->srcpkg ($_)->rules;
835    }
836    $makefile .= '# EOF' . "\n";
837
838    # Update Makefile
839    open OUT, '>', $self->dest->bldmakefile
840      or croak $self->dest->bldmakefile, ': cannot open (', $!, '), abort';
841    print OUT $makefile;
842    close OUT
843      or croak $self->dest->bldmakefile, ': cannot close (', $!, '), abort';
844
845    print $self->dest->bldmakefile, ': updated', "\n" if $self->verbose;
846
847    # Check for duplicated targets
848    # --------------------------------------------------------------------------
849    # Get list of types that cannot have duplicated targets
850    my @no_duplicated_target_types = split (
851      /$DELIMITER_LIST/,
852      $self->setting ('BLD_TYPE_NO_DUPLICATED_TARGET'),
853    );
854
855    my %targets;
856    for my $name (sort keys %{ $self->srcpkg }) {
857      next unless $self->srcpkg ($name)->rules;
858
859      for my $key (sort keys %{ $self->srcpkg ($name)->rules }) {
860        if (exists $targets{$key}) {
861          # Duplicated target: warning for most file types
862          my $status = 'WARNING';
863
864          # Duplicated target: error for the following file types
865          if (@no_duplicated_target_types and
866              $self->srcpkg ($name)->is_type_any (@no_duplicated_target_types) and
867              $targets{$key}->is_type_any (@no_duplicated_target_types)) {
868            $status = 'ERROR';
869            $rc = 0;
870          }
871
872          # Report the warning/error
873          w_report $status, ': ', $key, ': duplicated targets for building:';
874          w_report '       ', $targets{$key}->src;
875          w_report '       ', $self->srcpkg ($name)->src;
876
877        } else {
878          $targets{$key} = $self->srcpkg ($name);
879        }
880      }
881    }
882  }
883
884  return $rc;
885}
886
887# ------------------------------------------------------------------------------
888# SYNOPSIS
889#   $rc = $self->invoke_setup_build ();
890#
891# DESCRIPTION
892#   This method invokes the setup_build stage of the build system. It returns
893#   true on success.
894# ------------------------------------------------------------------------------
895
896sub invoke_setup_build {
897  my $self = shift;
898
899  my $rc = 1;
900
901  # Extract archived sub-directories if necessary
902  $rc = $self->dest->dearchive if $rc;
903
904  # Compare cache
905  $rc = $self->compare_setting (METHOD_LIST => [
906    'compare_setting_target', # targets
907    'compare_setting_srcpkg', # source package type
908    @compare_setting_methods,
909  ]) if $rc;
910
911  # Set up runtime dependency scan patterns
912  my %dep_pattern = %{ $self->setting ('BLD_DEP_PATTERN') };
913  for my $key (keys %dep_pattern) {
914    my $pattern = $dep_pattern{$key};
915
916    while ($pattern =~ /##([\w:]+)##/g) {
917      my $match = $1;
918      my $val   = $self->setting (split (/$FCM1::Config::DELIMITER/, $match));
919
920      last unless defined $val;
921      $val =~ s/\./\\./;
922
923      $pattern =~ s/##$match##/$val/;
924    }
925
926    $self->setting (['BLD_DEP_PATTERN', $key], $pattern)
927      unless $pattern eq $dep_pattern{$key};
928  }
929
930  return $rc;
931}
932
933# ------------------------------------------------------------------------------
934# SYNOPSIS
935#   $rc = $self->invoke_system (%args);
936#
937# DESCRIPTION
938#   This method invokes the build system. It returns true on success. See also
939#   the header for invoke_make for further information on arguments.
940#
941# ARGUMENTS
942#   STAGE - If set, it should be an integer number or a recognised keyword or
943#           abbreviation. If set, the build is performed up to the named stage.
944#           If not set, the default is to perform all stages of the build.
945#           Allowed values are:
946#             1, setup or s
947#             2, pre_process or pp
948#             3, generate_dependency or gd
949#             4, generate_interface or gi
950#             5, all, a, make or m
951# ------------------------------------------------------------------------------
952
953sub invoke_system {
954  my $self = shift;
955  my %args = @_;
956
957  # Parse arguments
958  # ----------------------------------------------------------------------------
959  # Default: run all 5 stages
960  my $stage = (exists $args{STAGE} and $args{STAGE}) ? $args{STAGE} : 5;
961
962  # Resolve named stages
963  if ($stage !~ /^\d$/) {
964    my %stagenames = (
965      'S(?:ETUP)?'                      => 1,
966      'P(?:RE)?_?P(?:ROCESS)?'          => 2,
967      'G(?:ENERATE)?_?D(?:ENPENDENCY)?' => 3,
968      'G(?:ENERATE)?_?I(?:NTERFACE)?'   => 4,
969      '(?:A(?:LL)|M(?:AKE)?)'           => 5,
970    );
971
972    # Does it match a recognised stage?
973    for my $name (keys %stagenames) {
974      next unless $stage =~ /$name/i;
975
976      $stage = $stagenames{$name};
977      last;
978    }
979
980    # Specified stage name not recognised, default to 5
981    if ($stage !~ /^\d$/) {
982      w_report 'WARNING: ', $stage, ': invalid build stage, default to 5.';
983      $stage = 5;
984    }
985  }
986
987  # Run the method associated with each stage
988  # ----------------------------------------------------------------------------
989  my $rc = 1;
990
991  my @stages = (
992    ['Setup build'               , 'invoke_setup_build'],
993    ['Pre-process'               , 'invoke_pre_process'],
994    ['Scan dependency'           , 'invoke_scan_dependency'],
995    ['Generate Fortran interface', 'invoke_fortran_interface_generator'],
996    ['Make'                      , 'invoke_make'],
997  );
998
999  for my $i (1 .. 5) {
1000    last if (not $rc) or $i > $stage;
1001
1002    my ($name, $method) = @{ $stages[$i - 1] };
1003    $rc = $self->invoke_stage ($name, $method, %args) if $rc and $stage >= $i;
1004  }
1005
1006  return $rc;
1007}
1008
1009# ------------------------------------------------------------------------------
1010# SYNOPSIS
1011#   $rc = $self->parse_cfg_dep (\@cfg_lines);
1012#
1013# DESCRIPTION
1014#   This method parses the dependency settings in the @cfg_lines.
1015# ------------------------------------------------------------------------------
1016
1017sub parse_cfg_dep {
1018  my ($self, $cfg_lines) = @_;
1019
1020  my $rc = 1;
1021
1022  # EXCL_DEP, EXE_DEP and BLOCKDATA declarations
1023  # ----------------------------------------------------------------------------
1024  for my $name (qw/BLD_BLOCKDATA BLD_DEP BLD_DEP_EXCL BLD_DEP_EXE/) {
1025    for my $line (grep {$_->slabel_starts_with_cfg ($name)} @$cfg_lines) {
1026      # Separate label into a list, delimited by double-colon, remove 1st field
1027      my @flds = $line->slabel_fields;
1028      shift @flds;
1029
1030      if ($name =~ /^(?:BLD_DEP|BLD_DEP_EXCL|BLD_DEP_PP)$/) {
1031        # BLD_DEP_*: label fields may contain sub-package
1032        my $pk = @flds ? join ('__', @flds) : '';
1033
1034        # Check whether sub-package is valid
1035        if ($pk and not ($self->srcpkg ($pk) or $self->dummysrcpkg ($pk))) {
1036          $line->error ($line->label . ': invalid sub-package in declaration.');
1037          $rc = 0;
1038          next;
1039        }
1040
1041        # Setting is stored in an array reference
1042        $self->setting ([$name, $pk], [])
1043          if not defined $self->setting ($name, $pk);
1044
1045        # Add current declaration to the array if necessary
1046        my $list  = $self->setting ($name, $pk);
1047        my $value = $name eq 'BLD_DEP_EXCL' ? uc ($line->value) : $line->value;
1048        push @$list, $value if not grep {$_ eq $value} @$list;
1049
1050      } else {
1051        # EXE_DEP and BLOCKDATA: label field may be an executable target
1052        my $target = @flds ? $flds[0] : '';
1053
1054        # The value contains a list of objects and/or sub-package names
1055        my @deps   = split /\s+/, $line->value;
1056
1057        if (not @deps) {
1058          if ($name eq 'BLD_BLOCKDATA') {
1059            # The objects containing a BLOCKDATA program unit must be declared
1060            $line->error ($line->label . ': value not set.');
1061            $rc = 0;
1062            next;
1063
1064          } else {
1065            # If $value is a null string, target(s) depends on all objects
1066            push @deps, '';
1067          }
1068        }
1069
1070        for my $dep (@deps) {
1071          $dep =~ s/$FCM1::Config::DELIMITER_PATTERN/__/g;
1072        }
1073
1074        $self->setting ([$name, $target], join (' ', sort @deps));
1075      }
1076
1077      $line->parsed (1);
1078    }
1079  }
1080
1081  return $rc;
1082}
1083
1084# ------------------------------------------------------------------------------
1085# SYNOPSIS
1086#   $rc = $self->parse_cfg_dest (\@cfg_lines);
1087#
1088# DESCRIPTION
1089#   This method parses the build destination settings in the @cfg_lines.
1090# ------------------------------------------------------------------------------
1091
1092sub parse_cfg_dest {
1093  my ($self, $cfg_lines) = @_;
1094
1095  my $rc = $self->SUPER::parse_cfg_dest ($cfg_lines);
1096
1097  # Set up search paths
1098  for my $name (@FCM1::Dest::paths) {
1099    (my $label = uc ($name)) =~ s/PATH//;
1100
1101    $self->setting (['PATH', $label], $self->dest->$name);
1102  }
1103
1104  return $rc;
1105}
1106
1107# ------------------------------------------------------------------------------
1108# SYNOPSIS
1109#   $rc = $self->parse_cfg_misc (\@cfg_lines);
1110#
1111# DESCRIPTION
1112#   This method parses misc build settings in the @cfg_lines.
1113# ------------------------------------------------------------------------------
1114
1115sub parse_cfg_misc {
1116    my ($self, $cfg_lines_ref) = @_;
1117    my $rc = 1;
1118    my %item_of = (
1119        BLD_DEP_N    => [\&_parse_cfg_misc_dep_n   , 1   ], # boolean
1120        BLD_EXE_NAME => [\&_parse_cfg_misc_exe_name      ],
1121        BLD_LIB      => [\&_parse_cfg_misc_dep_n         ],
1122        BLD_PP       => [\&_parse_cfg_misc_dep_n   , 1   ], # boolean
1123        BLD_TYPE     => [\&_parse_cfg_misc_dep_n         ],
1124        INFILE_EXT   => [\&_parse_cfg_misc_file_ext, 0, 1], # uc($value)
1125        OUTFILE_EXT  => [\&_parse_cfg_misc_file_ext, 1, 0], # uc($ns)
1126    );
1127    while (my ($key, $item) = each(%item_of)) {
1128        my ($handler, @extra_arguments) = @{$item};
1129        for my $line (@{$cfg_lines_ref}) {
1130            if ($line->slabel_starts_with_cfg($key)) {
1131                if ($handler->($self, $key, $line, @extra_arguments)) {
1132                    $line->parsed(1);
1133                }
1134                else {
1135                    $rc = 0;
1136                }
1137            }
1138        }
1139    }
1140    return $rc;
1141}
1142
1143# ------------------------------------------------------------------------------
1144# parse_cfg_misc: handler of BLD_EXE_NAME or similar.
1145sub _parse_cfg_misc_exe_name {
1146    my ($self, $key, $line) = @_;
1147    my ($prefix, $name, @fields) = $line->slabel_fields();
1148    if (!$name || @fields) {
1149        $line->error(sprintf('%s: expects a single label name field.', $key));
1150        return 0;
1151    }
1152    $self->setting([$key, $name], $line->value());
1153    return 1;
1154}
1155
1156# ------------------------------------------------------------------------------
1157# parse_cfg_misc: handler of BLD_DEP_N or similar.
1158sub _parse_cfg_misc_dep_n {
1159    my ($self, $key, $line, $value_is_boolean) = @_;
1160    my ($prefix, @fields) = $line->slabel_fields();
1161    my $ns = @fields ? join(q{__}, @fields) : q{};
1162    if ($ns && !$self->srcpkg($ns) && !$self->dummysrcpkg($ns)) {
1163        $line->error($line->label() . ': invalid sub-package in declaration.');
1164        return 0;
1165    }
1166    my @srcpkgs
1167        = $self->dummysrcpkg($ns) ? @{$self->dummysrcpkg($ns)->children()}
1168        :                           $self->srcpkg($ns)
1169        ;
1170    my $value = $value_is_boolean ? $line->bvalue() : $line->value();
1171    for my $srcpkg (@srcpkgs) {
1172        $self->setting([$key, $srcpkg->pkgname()], $value);
1173    }
1174    return 1;
1175}
1176
1177# ------------------------------------------------------------------------------
1178# parse_cfg_misc: handler of INFILE_EXT/OUTFILE_EXT or similar.
1179sub _parse_cfg_misc_file_ext {
1180    my ($self, $key, $line, $ns_in_uc, $value_in_uc) = @_;
1181    my ($prefix, $ns) = $line->slabel_fields();
1182    my $value = $value_in_uc ? uc($line->value()) : $line->value();
1183    $self->setting([$key, ($ns_in_uc ? uc($ns) : $ns)], $value);
1184    return 1;
1185}
1186
1187# ------------------------------------------------------------------------------
1188# SYNOPSIS
1189#   $rc = $self->parse_cfg_source (\@cfg_lines);
1190#
1191# DESCRIPTION
1192#   This method parses the source package settings in the @cfg_lines.
1193# ------------------------------------------------------------------------------
1194
1195sub parse_cfg_source {
1196  my ($self, $cfg_lines) = @_;
1197
1198  my $rc  = 1;
1199  my %src = ();
1200
1201  # Automatic source directory search?
1202  # ----------------------------------------------------------------------------
1203  my $search = 1;
1204
1205  for my $line (grep {$_->slabel_starts_with_cfg ('SEARCH_SRC')} @$cfg_lines) {
1206    $search = $line->bvalue;
1207    $line->parsed (1);
1208  }
1209
1210  # Search src/ sub-directory if necessary
1211  %src = %{ $self->dest->get_source_files } if $search;
1212
1213  # SRC declarations
1214  # ----------------------------------------------------------------------------
1215  for my $line (grep {$_->slabel_starts_with_cfg ('FILE')} @$cfg_lines) {
1216    # Expand ~ notation and path relative to srcdir of destination
1217    my $value = $line->value;
1218    $value = File::Spec->rel2abs (&expand_tilde ($value), $self->dest->srcdir);
1219
1220    if (! -e $value) {
1221      $line->error ($value . ': source does not exist or is not readable.');
1222      next;
1223    }
1224
1225    # Package name
1226    my @names = $line->slabel_fields;
1227    shift @names;
1228
1229    # If package name not set, determine using the path if possible
1230    if (not @names) {
1231      my $package = $self->dest->get_pkgname_of_path ($value);
1232      @names = @$package if defined $package;
1233    }
1234
1235    if (not @names) {
1236      $line->error ($self->cfglabel ('FILE') .
1237                    ': package not specified/cannot be determined.');
1238      next;
1239    }
1240
1241    $src{join ('__', @names)} = $value;
1242
1243    $line->parsed (1);
1244  }
1245
1246  # For directories, get non-recursive file listing, and add to %src
1247  # ----------------------------------------------------------------------------
1248  for my $key (keys %src) {
1249    next unless -d $src{$key};
1250
1251    opendir DIR, $src{$key} or die $src{$key}, ': cannot read directory';
1252    while (my $base = readdir 'DIR') {
1253      next if $base =~ /^\./;
1254
1255      my $file = File::Spec->catfile ($src{$key}, $base);
1256      next if ! -f $file;
1257
1258      my $name = join ('__', ($key, $base));
1259      $src{$name} = $file unless exists $src{$name};
1260    }
1261    closedir DIR;
1262
1263    delete $src{$key};
1264  }
1265
1266  # Set up source packages
1267  # ----------------------------------------------------------------------------
1268  my %pkg = ();
1269  for my $name (keys %src) {
1270    $pkg{$name} = FCM1::BuildSrc->new (PKGNAME => $name, SRC => $src{$name});
1271  }
1272
1273  # INHERIT::SRC declarations
1274  # ----------------------------------------------------------------------------
1275  my %can_inherit = ();
1276  for my $line (
1277    grep {$_->slabel_starts_with_cfg(qw/INHERIT FILE/)} @{$cfg_lines}
1278  ) {
1279    my ($key1, $key2, @ns) = $line->slabel_fields();
1280    $can_inherit{join('__', @ns)} = $line->bvalue();
1281    $line->parsed(1);
1282  }
1283
1284  # Inherit packages, if it is OK to do so
1285  for my $inherited_build (reverse(@{$self->inherit()})) {
1286    SRCPKG:
1287    while (my ($key, $srcpkg) = each(%{$inherited_build->srcpkg()})) {
1288      if (exists($pkg{$key}) || !$srcpkg->src()) {
1289        next SRCPKG;
1290      }
1291      my $known_key = first {exists($can_inherit{$_})} @{$srcpkg->pkgnames()};
1292      if (defined($known_key) && !$can_inherit{$known_key}) {
1293        next SRCPKG;
1294      }
1295      $pkg{$key} = $srcpkg;
1296    }
1297  }
1298
1299  # Get list of intermediate "packages"
1300  # ----------------------------------------------------------------------------
1301  for my $name (keys %pkg) {
1302    # Name of current package
1303    my @names = split /__/, $name;
1304
1305    my $cur = $name;
1306
1307    while ($cur) {
1308      # Name of parent package
1309      pop @names;
1310      my $parent = @names ? join ('__', @names) : '';
1311
1312      # If parent package does not exist, create it
1313      $pkg{$parent} = FCM1::BuildSrc->new (PKGNAME => $parent)
1314        unless exists $pkg{$parent};
1315
1316      # Current package is a child of the parent package
1317      push @{ $pkg{$parent}->children }, $pkg{$cur}
1318        unless grep {$_->pkgname eq $cur} @{ $pkg{$parent}->children };
1319
1320      # Go up a package
1321      $cur = $parent;
1322    }
1323  }
1324
1325  $self->srcpkg (\%pkg);
1326
1327  # Dummy: e.g. "foo/bar/baz.egg" belongs to the "foo/bar/baz" dummy.
1328  # ----------------------------------------------------------------------------
1329  SRCPKG:
1330  while (my ($name, $srcpkg) = each(%pkg)) {
1331    if (!$srcpkg->src()) { # ensure that $srcpkg represents a source file
1332      next SRCPKG;
1333    }
1334    my @names = split('__', $name);
1335    if (@names) {
1336      $names[-1] =~ s{\.\w+ \z}{}msx;
1337    }
1338    my $dummy_name = join('__', @names);
1339    if ($dummy_name eq $name || defined($self->srcpkg($dummy_name))) {
1340      next SRCPKG;
1341    }
1342    if (!defined($self->dummysrcpkg($dummy_name))) {
1343      $self->dummysrcpkg($dummy_name, FCM1::BuildSrc->new(PKGNAME => $dummy_name));
1344    }
1345    push(@{$self->dummysrcpkg($dummy_name)->children()}, $srcpkg);
1346  }
1347
1348  # Make sure a package is defined
1349  # ----------------------------------------------------------------------------
1350  if (not %{$self->srcpkg}) {
1351    w_report 'ERROR: ', $self->cfg->actual_src, ': no source file to build.';
1352    $rc = 0;
1353  }
1354
1355  return $rc;
1356}
1357
1358# ------------------------------------------------------------------------------
1359# SYNOPSIS
1360#   $rc = $self->parse_cfg_target (\@cfg_lines);
1361#
1362# DESCRIPTION
1363#   This method parses the target settings in the @cfg_lines.
1364# ------------------------------------------------------------------------------
1365
1366sub parse_cfg_target {
1367  my ($self, $cfg_lines) = @_;
1368
1369  # NAME declaraions
1370  # ----------------------------------------------------------------------------
1371  for my $line (grep {$_->slabel_starts_with_cfg ('NAME')} @$cfg_lines) {
1372    $self->name ($line->value);
1373    $line->parsed (1);
1374  }
1375
1376  # TARGET declarations
1377  # ----------------------------------------------------------------------------
1378  for my $line (grep {$_->slabel_starts_with_cfg ('TARGET')} @$cfg_lines) {
1379    # Value is a space delimited list
1380    push @{ $self->target }, split (/\s+/, $line->value);
1381    $line->parsed (1);
1382  }
1383
1384  # INHERIT::TARGET declarations
1385  # ----------------------------------------------------------------------------
1386  # By default, do not inherit target
1387  my $inherit_flag = 0;
1388
1389  for (grep {$_->slabel_starts_with_cfg (qw/INHERIT TARGET/)} @$cfg_lines) {
1390    $inherit_flag = $_->bvalue;
1391    $_->parsed (1);
1392  }
1393
1394  # Inherit targets from inherited build, if $inherit_flag is set to true
1395  # ----------------------------------------------------------------------------
1396  if ($inherit_flag) {
1397    for my $use (reverse @{ $self->inherit }) {
1398      unshift @{ $self->target }, @{ $use->target };
1399    }
1400  }
1401
1402  return 1;
1403}
1404
1405# ------------------------------------------------------------------------------
1406# SYNOPSIS
1407#   $rc = $self->parse_cfg_tool (\@cfg_lines);
1408#
1409# DESCRIPTION
1410#   This method parses the tool settings in the @cfg_lines.
1411# ------------------------------------------------------------------------------
1412
1413sub parse_cfg_tool {
1414  my ($self, $cfg_lines) = @_;
1415
1416  my $rc = 1;
1417
1418  my %tools         = %{ $self->setting ('TOOL') };
1419  my @package_tools = split(/$DELIMITER_LIST/, $self->setting('TOOL_PACKAGE'));
1420
1421  # TOOL declaration
1422  # ----------------------------------------------------------------------------
1423  for my $line (grep {$_->slabel_starts_with_cfg ('TOOL')} @$cfg_lines) {
1424    # Separate label into a list, delimited by double-colon, remove TOOL
1425    my @flds = $line->slabel_fields;
1426    shift @flds;
1427
1428    # Check that there is a field after TOOL
1429    if (not @flds) {
1430      $line->error ('TOOL: not followed by a valid label.');
1431      $rc = 0;
1432      next;
1433    }
1434
1435    # The first field is the tool iteself, identified in uppercase
1436    $flds[0] = uc ($flds[0]);
1437
1438    # Check that the tool is recognised
1439    if (not exists $tools{$flds[0]}) {
1440      $line->error ($flds[0] . ': not a valid TOOL.');
1441      $rc = 0;
1442      next;
1443    }
1444
1445    # Check sub-package declaration
1446    if (@flds > 1 and not grep {$_ eq $flds[0]} @package_tools) {
1447      $line->error ($flds[0] . ': sub-package not accepted with this TOOL.');
1448      $rc = 0;
1449      next;
1450    }
1451
1452    # Name of declared package
1453    my $pk = join ('__', @flds[1 .. $#flds]);
1454
1455    # Check whether package exists
1456    if (not ($self->srcpkg ($pk) or $self->dummysrcpkg ($pk))) {
1457      $line->error ($line->label . ': invalid sub-package in declaration.');
1458      $rc = 0;
1459      next;
1460    }
1461
1462    $self->setting (['TOOL', join ('__', @flds)], $line->value);
1463    $line->parsed (1);
1464  }
1465
1466  return $rc;
1467}
1468
1469# ------------------------------------------------------------------------------
1470# SYNOPSIS
1471#   $string = $self->_write_makefile_perl5lib ();
1472#
1473# DESCRIPTION
1474#   This method returns a makefile $string for defining $PERL5LIB.
1475# ------------------------------------------------------------------------------
1476
1477sub _write_makefile_perl5lib {
1478  my $self = shift;
1479
1480  my $classpath = File::Spec->catfile (split (/::/, ref ($self))) . '.pm';
1481
1482  my $libdir  = dirname (dirname ($INC{$classpath}));
1483  my @libpath = split (/:/, (exists $ENV{PERL5LIB} ? $ENV{PERL5LIB} : ''));
1484
1485  my $string = ((grep {$_ eq $libdir} @libpath)
1486                ? ''
1487                : 'export PERL5LIB := ' . $libdir .
1488                  (exists $ENV{PERL5LIB} ? ':$(PERL5LIB)' : '') . "\n\n");
1489
1490  return $string;
1491}
1492
1493# ------------------------------------------------------------------------------
1494# SYNOPSIS
1495#   $string = $self->_write_makefile_target ();
1496#
1497# DESCRIPTION
1498#   This method returns a makefile $string for defining the default targets.
1499# ------------------------------------------------------------------------------
1500
1501sub _write_makefile_target {
1502  my $self = shift;
1503
1504  # Targets of the build
1505  # ----------------------------------------------------------------------------
1506  my @targets = @{ $self->target };
1507  if (not @targets) {
1508    # Build targets not specified by user, default to building all main programs
1509    my @programs = ();
1510
1511    # Get all main programs from all packages
1512    for my $pkg (values %{ $self->srcpkg }) {
1513      push @programs, $pkg->exebase if $pkg->exebase;
1514    }
1515
1516    @programs = sort (@programs);
1517
1518    if (@programs) {
1519      # Build main programs, if there are any
1520      @targets = @programs;
1521
1522    } else {
1523      # No main program in source tree, build the default library
1524      @targets = ($self->srcpkg ('')->libbase);
1525    }
1526  }
1527
1528  my $return = 'FCM_BLD_TARGETS = ' . join (' ', @targets) . "\n\n";
1529
1530  # Default targets
1531  $return .= '.PHONY : all' . "\n\n";
1532  $return .= 'all : $(FCM_BLD_TARGETS)' . "\n\n";
1533
1534  # Targets for copy dummy
1535  $return .= sprintf("%s:\n\ttouch \$@\n\n", $self->setting(qw/BLD_CPDUMMY/));
1536
1537  return $return;
1538}
1539
1540# ------------------------------------------------------------------------------
1541# SYNOPSIS
1542#   $string = $self->_write_makefile_tool ();
1543#
1544# DESCRIPTION
1545#   This method returns a makefile $string for defining the build tools.
1546# ------------------------------------------------------------------------------
1547
1548sub _write_makefile_tool {
1549  my $self = shift;
1550
1551  # List of build tools
1552  my $tool = $self->setting ('TOOL');
1553
1554  # List of tools local to FCM, (will not be exported)
1555  my %localtool = map {($_, 1)} split ( # map into a hash table
1556    /$DELIMITER_LIST/, $self->setting ('TOOL_LOCAL'),
1557  );
1558
1559  # Export required tools
1560  my $count = 0;
1561  my $return = '';
1562  for my $name (sort keys %$tool) {
1563    # Ignore local tools
1564    next if exists $localtool{(split (/__/, $name))[0]};
1565
1566    if ($name =~ /^\w+$/) {
1567      # Tools with normal name, just export it as an environment variable
1568      $return .= 'export ' . $name . ' = ' . $tool->{$name} . "\n";
1569
1570    } else {
1571      # Tools with unusual characters, export using a label/value pair
1572      $return .= 'export FCM_UNUSUAL_TOOL_LABEL' . $count . ' = ' . $name . "\n";
1573      $return .= 'export FCM_UNUSUAL_TOOL_VALUE' . $count . ' = ' .
1574                 $tool->{$name} . "\n";
1575      $count++;
1576    }
1577  }
1578
1579  $return .= "\n";
1580
1581  return $return;
1582}
1583
1584# ------------------------------------------------------------------------------
1585# SYNOPSIS
1586#   $string = $self->_write_makefile_vpath ();
1587#
1588# DESCRIPTION
1589#   This method returns a makefile $string for defining vpath directives.
1590# ------------------------------------------------------------------------------
1591
1592sub _write_makefile_vpath {
1593  my $self = shift();
1594  my $FMT = 'vpath %%%s $(FCM_%sPATH)';
1595  my %SETTING_OF = %{$self->setting('BLD_VPATH')};
1596  my %EXT_OF = %{$self->setting('OUTFILE_EXT')};
1597  # Note: each setting can be either an empty string or a comma-separated list
1598  # of output file extension keys.
1599  join(
1600    "\n",
1601    (
1602      map
1603      {
1604        my $key = $_;
1605        my @types = split(qr{$DELIMITER_LIST}msx, $SETTING_OF{$key});
1606          @types ? (map {sprintf($FMT, $EXT_OF{$_}, $key)} sort @types)
1607        :          sprintf($FMT, q{}, $key)
1608        ;
1609      }
1610      sort keys(%SETTING_OF)
1611    ),
1612  ) . "\n\n";
1613}
1614
1615# Wraps chdir. Returns the old working directory.
1616sub _chdir {
1617  my ($self, $path) = @_;
1618  if ($self->verbose() >= 3) {
1619    printf("cd %s\n", $path);
1620  }
1621  my $old_cwd = cwd();
1622  chdir($path) || croak(sprintf("%s: cannot change directory ($!)\n", $path));
1623  $old_cwd;
1624}
1625
1626# ------------------------------------------------------------------------------
1627
16281;
1629
1630__END__
Note: See TracBrowser for help on using the repository browser.