source: branches/2015/dev_r5021_UKMO1_CICE_coupling/NEMOGCM/EXTERNAL/fcm/lib/Fcm/Build.pm @ 5445

Last change on this file since 5445 was 5445, checked in by davestorkey, 5 years ago

Clear SVN keywords from 2015/dev_r5021_UKMO1_CICE_coupling branch.

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