source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM1/BuildSrc.pm @ 5134

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

Re-add removed by mistake fcm
File size: 44.9 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::BuildSrc
21#
22# DESCRIPTION
23#   This is a class to group functionalities of source in a build.
24#
25# ------------------------------------------------------------------------------
26
27use strict;
28use warnings;
29
30package FCM1::BuildSrc;
31use base qw{FCM1::Base};
32
33use Carp qw{croak};
34use Cwd qw{cwd};
35use FCM1::Build::Fortran;
36use FCM1::CfgFile;
37use FCM1::CfgLine;
38use FCM1::Config;
39use FCM1::Timer qw{timestamp_command};
40use FCM1::Util qw{find_file_in_path run_command};
41use File::Basename qw{basename dirname};
42use File::Spec;
43
44# List of scalar property methods for this class
45my @scalar_properties = (
46  'children',   # list of children packages
47  'is_updated', # is this source (or its associated settings) updated?
48  'mtime',      # modification time of src
49  'ppmtime',    # modification time of ppsrc
50  'ppsrc',      # full path of the pre-processed source
51  'pkgname',    # package name of the source
52  'progname',   # program unit name in the source
53  'src',        # full path of the source
54  'type',       # type of the source
55);
56
57# List of hash property methods for this class
58my @hash_properties = (
59  'dep',   # dependencies
60  'ppdep', # pre-process dependencies
61  'rules', # make rules
62);
63
64# Error message formats
65my %ERR_MESS_OF = (
66  CHDIR       => '%s: cannot change directory (%s), abort',
67  OPEN        => '%s: cannot open (%s), abort',
68  CLOSE_PIPE  => '%s: failed (%d), abort',
69);
70
71# Event message formats and levels
72my %EVENT_SETTING_OF = (
73  CHDIR            => ['%s: change directory'                   , 2],
74  F_INTERFACE_NONE => ['%s: Fortran interface generation is off', 3],
75  GET_DEPENDENCY   => ['%s: %d line(s), %d auto dependency(ies)', 3],
76);
77
78my %RE_OF = (
79  F_PREFIX => qr{
80    (?:
81      (?:ELEMENTAL|PURE(?:\s+RECURSIVE)?|RECURSIVE(?:\s+PURE)?)
82      \s+
83    )?
84  }imsx,
85  F_SPEC => qr{
86    (?:
87      (?:CHARACTER|COMPLEX|DOUBLE\s*PRECISION|INTEGER|LOGICAL|REAL|TYPE)
88      (?: \s* \( .+ \) | \s* \* \d+ \s*)??
89      \s+
90    )?
91  }imsx,
92);
93
94{
95  # Returns a singleton instance of FCM1::Build::Fortran.
96  my $FORTRAN_UTIL;
97  sub _get_fortran_util {
98    $FORTRAN_UTIL ||= FCM1::Build::Fortran->new();
99    return $FORTRAN_UTIL;
100  }
101}
102
103# ------------------------------------------------------------------------------
104# SYNOPSIS
105#   $obj = FCM1::BuildSrc->new (%args);
106#
107# DESCRIPTION
108#   This method constructs a new instance of the FCM1::BuildSrc class. See
109#   above for allowed list of properties. (KEYS should be in uppercase.)
110# ------------------------------------------------------------------------------
111
112sub new {
113  my ($class, %args) = @_;
114  my $self = bless(FCM1::Base->new(%args), $class);
115  for my $key (@scalar_properties, @hash_properties) {
116    $self->{$key}
117      = exists($args{uc($key)}) ? $args{uc($key)}
118      :                           undef
119      ;
120  }
121  $self;
122}
123
124# ------------------------------------------------------------------------------
125# SYNOPSIS
126#   $value = $obj->X;
127#   $obj->X ($value);
128#
129# DESCRIPTION
130#   Details of these properties are explained in @scalar_properties.
131# ------------------------------------------------------------------------------
132
133for my $name (@scalar_properties) {
134  no strict 'refs';
135
136  *$name = sub {
137    my $self = shift;
138
139    # Argument specified, set property to specified argument
140    if (@_) {
141      $self->{$name} = $_[0];
142
143      if ($name eq 'ppsrc') {
144        $self->ppmtime (undef);
145
146      } elsif ($name eq 'src') {
147        $self->mtime (undef);
148      }
149    }
150
151    # Default value for property
152    if (not defined $self->{$name}) {
153      if ($name eq 'children') {
154        # Reference to an empty array
155        $self->{$name} = [];
156       
157      } elsif ($name =~ /^(?:is_cur|pkgname|ppsrc|src)$/) {
158        # Empty string
159        $self->{$name} = '';
160       
161      } elsif ($name eq 'mtime') {
162        # Modification time
163        $self->{$name} = (stat $self->src)[9] if $self->src;
164       
165      } elsif ($name eq 'ppmtime') {
166        # Modification time
167        $self->{$name} = (stat $self->ppsrc)[9] if $self->ppsrc;
168       
169      } elsif ($name eq 'type') {
170        # Attempt to get the type if src is set
171        $self->{$name} = $self->get_type if $self->src;
172      }
173    }
174
175    return $self->{$name};
176  }
177}
178
179# ------------------------------------------------------------------------------
180# SYNOPSIS
181#   %hash = %{ $obj->X () };
182#   $obj->X (\%hash);
183#
184#   $value = $obj->X ($index);
185#   $obj->X ($index, $value);
186#
187# DESCRIPTION
188#   Details of these properties are explained in @hash_properties.
189#
190#   If no argument is set, this method returns a hash containing a list of
191#   objects. If an argument is set and it is a reference to a hash, the objects
192#   are replaced by the specified hash.
193#
194#   If a scalar argument is specified, this method returns a reference to an
195#   object, if the indexed object exists or undef if the indexed object does
196#   not exist. If a second argument is set, the $index element of the hash will
197#   be set to the value of the argument.
198# ------------------------------------------------------------------------------
199
200for my $name (@hash_properties) {
201  no strict 'refs';
202
203  *$name = sub {
204    my ($self, $arg1, $arg2) = @_;
205
206    # Ensure property is defined as a reference to a hash
207    if (not defined $self->{$name}) {
208      if ($name eq 'rules') {
209        $self->{$name} = $self->get_rules;
210
211      } else {
212        $self->{$name} = {};
213      }
214    }
215
216    # Argument 1 can be a reference to a hash or a scalar index
217    my ($index, %hash);
218
219    if (defined $arg1) {
220      if (ref ($arg1) eq 'HASH') {
221        %hash = %$arg1;
222
223      } else {
224        $index = $arg1;
225      }
226    }
227
228    if (defined $index) {
229      # A scalar index is defined, set and/or return the value of an element
230      $self->{$name}{$index} = $arg2 if defined $arg2;
231
232      return (
233        exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
234      );
235
236    } else {
237      # A scalar index is not defined, set and/or return the hash
238      $self->{$name} = \%hash if defined $arg1;
239      return $self->{$name};
240    }
241  }
242}
243
244# ------------------------------------------------------------------------------
245# SYNOPSIS
246#   $value = $obj->X;
247#   $obj->X ($value);
248#
249# DESCRIPTION
250#   This method returns/sets property X, all derived from src, where X is:
251#     base  - (read-only) basename of src
252#     dir   - (read-only) dirname of src
253#     ext   - (read-only) file extension of src
254#     root  - (read-only) basename of src without the file extension
255# ------------------------------------------------------------------------------
256
257sub base {
258  return &basename ($_[0]->src);
259}
260
261# ------------------------------------------------------------------------------
262
263sub dir {
264  return &dirname ($_[0]->src);
265}
266
267# ------------------------------------------------------------------------------
268
269sub ext {
270  return substr $_[0]->base, length ($_[0]->root);
271}
272
273# ------------------------------------------------------------------------------
274
275sub root {
276  (my $root = $_[0]->base) =~ s/\.\w+$//;
277  return $root;
278}
279
280# ------------------------------------------------------------------------------
281# SYNOPSIS
282#   $value = $obj->X;
283#   $obj->X ($value);
284#
285# DESCRIPTION
286#   This method returns/sets property X, all derived from ppsrc, where X is:
287#     ppbase  - (read-only) basename of ppsrc
288#     ppdir   - (read-only) dirname of ppsrc
289#     ppext   - (read-only) file extension of ppsrc
290#     pproot  - (read-only) basename of ppsrc without the file extension
291# ------------------------------------------------------------------------------
292
293sub ppbase {
294  return &basename ($_[0]->ppsrc);
295}
296
297# ------------------------------------------------------------------------------
298
299sub ppdir {
300  return &dirname ($_[0]->ppsrc);
301}
302
303# ------------------------------------------------------------------------------
304
305sub ppext {
306  return substr $_[0]->ppbase, length ($_[0]->pproot);
307}
308
309# ------------------------------------------------------------------------------
310
311sub pproot {
312  (my $root = $_[0]->ppbase) =~ s/\.\w+$//;
313  return $root;
314}
315
316# ------------------------------------------------------------------------------
317# SYNOPSIS
318#   $value = $obj->X;
319#
320# DESCRIPTION
321#   This method returns/sets property X, derived from src or ppsrc, where X is:
322#     curbase  - (read-only) basename of cursrc
323#     curdir   - (read-only) dirname of cursrc
324#     curext   - (read-only) file extension of cursrc
325#     curmtime - (read-only) modification time of cursrc
326#     curroot  - (read-only) basename of cursrc without the file extension
327#     cursrc   - ppsrc or src
328# ------------------------------------------------------------------------------
329
330for my $name (qw/base dir ext mtime root src/) {
331  no strict 'refs';
332
333  my $subname = 'cur' . $name;
334
335  *$subname = sub {
336    my $self = shift;
337    my $method = $self->ppsrc ? 'pp' . $name : $name;
338    return $self->$method (@_);
339  }
340}
341
342# ------------------------------------------------------------------------------
343# SYNOPSIS
344#   $base = $obj->X ();
345#
346# DESCRIPTION
347#   This method returns a basename X for the source, where X is:
348#     donebase      - "done" file name
349#     etcbase       - target for copying data files
350#     exebase       - executable name for source containing a main program
351#     interfacebase - Fortran interface file name
352#     libbase       - library file name
353#     objbase       - object name for source containing compilable source
354#   If the source file contains a compilable procedure, this method returns
355#   the name of the object file.
356# ------------------------------------------------------------------------------
357
358sub donebase {
359  my $self   = shift;
360
361  my $return;
362  if ($self->is_type_all ('SOURCE')) {
363    if ($self->objbase and not $self->is_type_all ('PROGRAM')) {
364      $return = ($self->progname ? $self->progname : lc ($self->curroot)) .
365                $self->setting (qw/OUTFILE_EXT DONE/);
366    }
367
368  } elsif ($self->is_type_all ('INCLUDE')) {
369    $return = $self->curbase . $self->setting (qw/OUTFILE_EXT IDONE/);
370  }
371
372  return $return;
373}
374
375# ------------------------------------------------------------------------------
376
377sub etcbase {
378  my $self = shift;
379
380  my $return = @{ $self->children }
381               ? $self->pkgname . $self->setting (qw/OUTFILE_EXT ETC/)
382               : undef;
383
384  return $return;
385}
386
387# ------------------------------------------------------------------------------
388
389sub exebase {
390  my $self = shift;
391
392  my $return;
393  if ($self->objbase and $self->is_type_all ('PROGRAM')) {
394    if ($self->setting ('BLD_EXE_NAME', $self->curroot)) {
395      $return = $self->setting ('BLD_EXE_NAME', $self->curroot);
396
397    } else {
398      $return = $self->curroot . $self->setting (qw/OUTFILE_EXT EXE/);
399    }
400  }
401
402  return $return;
403}
404
405# ------------------------------------------------------------------------------
406
407sub interfacebase {
408  my $self = shift();
409  if (
410        defined($self->get_setting(qw/TOOL GENINTERFACE/))
411    &&  uc($self->get_setting(qw/TOOL GENINTERFACE/)) ne 'NONE'
412    &&  $self->progname()
413    &&  $self->is_type_all(qw/SOURCE/)
414    &&  $self->is_type_any(qw/FORTRAN9X FPP9X/)
415    &&  !$self->is_type_any(qw/PROGRAM MODULE BLOCKDATA/)
416  ) {
417    my $flag = lc($self->get_setting(qw/TOOL INTERFACE/));
418    my $ext  = $self->setting(qw/OUTFILE_EXT INTERFACE/);
419
420    return (($flag eq 'program' ? $self->progname() : $self->curroot()) . $ext);
421  }
422  return;
423}
424
425# ------------------------------------------------------------------------------
426
427sub objbase {
428  my $self = shift;
429
430  my $return;
431
432  if ($self->is_type_all ('SOURCE')) {
433    my $ext = $self->setting (qw/OUTFILE_EXT OBJ/);
434
435    if ($self->is_type_any (qw/FORTRAN FPP/)) {
436      $return = lc ($self->progname) . $ext if $self->progname;
437
438    } else {
439      $return = lc ($self->curroot) . $ext;
440    }
441  }
442
443  return $return;
444}
445
446# ------------------------------------------------------------------------------
447# SYNOPSIS
448#   $value = $obj->flagsbase ($flag, [$index,]);
449#
450# DESCRIPTION
451#   Returns the base name of the flags file for the current package namespace
452#   for a given $flag. The returned base name should look like
453#   "LABEL___PACKAGE__NAME__SPACE.flags", where "LABEL" is normally the $flag,
454#   and "PACKAGE__NAME__SPACE" is the current package namespace without the file
455#   extension. If $flag is FLAGS or PPKEYS and $self->lang() is defined, it
456#   will attempt to determine the correct label for the language. E.g. If
457#   $self->lang() is 'C', the label will be "CFLAGS". If $index is set, returns
458#   the base name of the flags file for the $index'th element in package name
459#   space (as described in "pkgnames" method) instead of the current package
460#   name space.
461# ------------------------------------------------------------------------------
462
463sub flagsbase {
464  my ($self, $flag, $index) = @_;
465  my $name = $index ? $self->pkgnames()->[$index] : $self->pkgname();
466  my @names = split('__', $name);
467  if (@names && $self->src() && $name eq $self->pkgname()) {
468    $names[-1] =~ s{\.\w+ \z}{}msx;
469  }
470  my $label = $flag;
471  if ($self->lang() && ($flag eq 'FLAGS' || $flag eq 'PPKEYS')) {
472    if (!exists($self->setting('TOOL_SRC')->{$self->lang()}{$flag})) {
473      return;
474    }
475    $label = $self->setting('TOOL_SRC')->{$self->lang()}{$flag};
476  }
477  join('__', $label, @names) . $self->setting(qw/OUTFILE_EXT FLAGS/);
478}
479
480# ------------------------------------------------------------------------------
481# SYNOPSIS
482#   $value = $obj->libbase ([$prefix], [$suffix]);
483#
484# DESCRIPTION
485#   This method returns the property libbase (derived from pkgname) the base
486#   name of the library archive. $prefix and $suffix defaults to 'lib' and '.a'
487#   respectively.
488# ------------------------------------------------------------------------------
489
490sub libbase {
491  my ($self, $prefix, $suffix) = @_;
492  $prefix ||= 'lib';
493  $suffix ||= $self->setting(qw/OUTFILE_EXT LIB/);
494  if ($self->src()) { # applies to directories only
495    return;
496  }
497  my $name = $self->setting('BLD_LIB', $self->pkgname());
498  if (!defined($name)) {
499    $name = $self->pkgname();
500  }
501  $prefix . $name . $suffix;
502}
503
504# ------------------------------------------------------------------------------
505# SYNOPSIS
506#   $value = $obj->lang ([$setting]);
507#
508# DESCRIPTION
509#   This method returns the property lang (derived from type) the programming
510#   language name if type matches one supported in the TOOL_SRC setting. If
511#   $setting is specified, use $setting instead of TOOL_SRC.
512# ------------------------------------------------------------------------------
513
514sub lang {
515  my ($self, $setting) = @_;
516
517  my @keys = keys %{ $self->setting ($setting ? $setting : 'TOOL_SRC') };
518
519  my $return = undef;
520  for my $key (@keys) {
521    next unless $self->is_type_all ('SOURCE', $key);
522    $return = $key;
523    last;
524  }
525
526  return $return;
527}
528
529# ------------------------------------------------------------------------------
530# SYNOPSIS
531#   $value = $obj->pkgnames;
532#
533# DESCRIPTION
534#   This method returns a list of container packages, derived from pkgname:
535# ------------------------------------------------------------------------------
536
537sub pkgnames {
538  my $self = shift;
539
540  my $return = [];
541  if ($self->pkgname) {
542    my @names = split (/__/, $self->pkgname);
543
544    for my $i (0 .. $#names) {
545      push @$return, join ('__', (@names[0 .. $i]));
546    }
547
548    unshift @$return, '';
549  }
550
551  return $return;
552}
553
554# ------------------------------------------------------------------------------
555# SYNOPSIS
556#   %dep = %{$obj->get_dep()};
557#   %dep = %{$obj->get_dep($flag)};
558#
559# DESCRIPTION
560#   This method scans the current source file for dependencies and returns the
561#   dependency hash (keys = dependencies, values = dependency types). If $flag
562#   is specified, the config setting for $flag is used to determine the types of
563#   types. Otherwise, those specified in 'BLD_TYPE_DEP' is used.
564# ------------------------------------------------------------------------------
565
566sub get_dep {
567  my ($self, $flag) = @_;
568  # Work out list of exclude for this file, using its sub-package name
569  my %EXCLUDE_SET = map {($_, 1)} @{$self->get_setting('BLD_DEP_EXCL')};
570  # Determine what dependencies are supported by this known type
571  my %DEP_TYPE_OF = %{$self->setting($flag ? $flag : 'BLD_TYPE_DEP')};
572  my %PATTERN_OF = %{$self->setting('BLD_DEP_PATTERN')};
573  my @dep_types = ();
574  if (!$self->get_setting('BLD_DEP_N')) {
575    DEP_TYPE:
576    while (my ($key, $dep_type_string) = each(%DEP_TYPE_OF)) {
577      # Check if current file is a type of file requiring dependency scan
578      if (!$self->is_type_all($key)) {
579        next DEP_TYPE;
580      }
581      # Get list of dependency type for this file
582      for my $dep_type (split(/$FCM1::Config::DELIMITER/, $dep_type_string)) {
583        if (exists($PATTERN_OF{$dep_type}) && !exists($EXCLUDE_SET{$dep_type})) {
584          push(@dep_types, $dep_type);
585        }
586      }
587    }
588  }
589
590  # Automatic dependencies
591  my %dep_of;
592  my $can_get_symbol # Also scan for program unit name in Fortran source
593      =  !$flag
594      && $self->is_type_all('SOURCE')
595      && $self->is_type_any(qw/FPP FORTRAN/)
596      ;
597  my $has_read_file;
598  if ($can_get_symbol || @dep_types) {
599    my $handle = _open($self->cursrc());
600    LINE:
601    while (my $line = readline($handle)) {
602      chomp($line);
603      if ($line =~ qr{\A \s* \z}msx) { # empty lines
604        next LINE;
605      }
606      if ($can_get_symbol) {
607        my $symbol = _get_dep_symbol($line);
608        if ($symbol) {
609          $self->progname($symbol);
610          $can_get_symbol = 0;
611          next LINE;
612        }
613      }
614      DEP_TYPE:
615      for my $dep_type (@dep_types) {
616        my ($match) = $line =~ /$PATTERN_OF{$dep_type}/i;
617        if (!$match) {
618          next DEP_TYPE;
619        }
620        # $match may contain multiple items delimited by space
621        for my $item (split(qr{\s+}msx, $match)) {
622          my $key = uc($dep_type . $FCM1::Config::DELIMITER . $item);
623          if (!exists($EXCLUDE_SET{$key})) {
624            $dep_of{$item} = $dep_type;
625          }
626        }
627        next LINE;
628      }
629    }
630    $self->_event('GET_DEPENDENCY', $self->pkgname(), $., scalar(keys(%dep_of)));
631    close($handle);
632    $has_read_file = 1;
633  }
634
635  # Manual dependencies
636  my $manual_deps_ref
637      = $self->setting('BLD_DEP' . ($flag ? '_PP' : ''), $self->pkgname());
638  if (defined($manual_deps_ref)) {
639    for (@{$manual_deps_ref}) {
640      my ($dep_type, $item) = split(/$FCM1::Config::DELIMITER/, $_, 2);
641      $dep_of{$item} = $dep_type;
642    }
643  }
644
645  return ($has_read_file, \%dep_of);
646}
647
648# Returns, if possible, the program unit declared in the $line.
649sub _get_dep_symbol {
650  my $line = shift();
651  for my $pattern (
652    qr{\A \s* $RE_OF{F_PREFIX} SUBROUTINE              \s+ ([A-Za-z]\w*)}imsx,
653    qr{\A \s* MODULE (?!\s+PROCEDURE)                  \s+ ([A-Za-z]\w*)}imsx,
654    qr{\A \s* PROGRAM                                  \s+ ([A-Za-z]\w*)}imsx,
655    qr{\A \s* $RE_OF{F_PREFIX} $RE_OF{F_SPEC} FUNCTION \s+ ([A-Za-z]\w*)}imsx,
656    qr{\A \s* BLOCK\s*DATA                             \s+ ([A-Za-z]\w*)}imsx,
657  ) {
658    my ($match) = $line =~ $pattern;
659    if ($match) {
660      return lc($match);
661    }
662  }
663  return;
664}
665
666# ------------------------------------------------------------------------------
667# SYNOPSIS
668#   @out = @{ $obj->get_fortran_interface () };
669#
670# DESCRIPTION
671#   This method invokes the Fortran interface block generator to generate
672#   an interface block for the current source file. It returns a reference to
673#   an array containing the lines of the interface block.
674# ------------------------------------------------------------------------------
675
676sub get_fortran_interface {
677  my $self = shift();
678  my %ACTION_OF = (
679    q{}    => \&_get_fortran_interface_by_internal_code,
680    f90aib => \&_get_fortran_interface_by_f90aib,
681    none   => sub {$self->_event('F_INTERFACE_NONE', $self->root()); []},
682  );
683  my $key = lc($self->get_setting(qw/TOOL GENINTERFACE/));
684  if (!$key || !exists($ACTION_OF{$key})) {
685    $key = q{};
686  }
687  $ACTION_OF{$key}->($self->cursrc());
688}
689
690# Generates Fortran interface block using "f90aib".
691sub _get_fortran_interface_by_f90aib {
692  my $path = shift();
693  my $command = sprintf(q{f90aib <'%s' 2>'%s'}, $path, File::Spec->devnull());
694  my $pipe = _open($command, '-|');
695  my @lines = readline($pipe);
696  close($pipe) || croak($ERR_MESS_OF{CLOSE_PIPE}, $command, $?);
697  \@lines;
698}
699
700# Generates Fortran interface block using internal code.
701sub _get_fortran_interface_by_internal_code {
702  my $path = shift();
703  my $handle = _open($path);
704  my @lines = _get_fortran_util()->extract_interface($handle);
705  close($handle);
706  \@lines;
707}
708
709# ------------------------------------------------------------------------------
710# SYNOPSIS
711#   @out = @{ $obj->get_pre_process () };
712#
713# DESCRIPTION
714#   This method invokes the pre-processor on the source file and returns a
715#   reference to an array containing the lines of the pre-processed source on
716#   success.
717# ------------------------------------------------------------------------------
718
719sub get_pre_process {
720  my $self = shift;
721
722  # Supported source files
723  my $lang = $self->lang ('TOOL_SRC_PP');
724  return unless $lang;
725
726  # List of include directories
727  my @inc = @{ $self->setting (qw/PATH INC/) };
728
729  # Build the pre-processor command according to file type
730  my %tool        = %{ $self->setting ('TOOL') };
731  my %tool_src_pp = %{ $self->setting ('TOOL_SRC_PP', $lang) };
732
733  # The pre-processor command and its options
734  my @command = ($tool{$tool_src_pp{COMMAND}});
735  my @ppflags = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{FLAGS});
736
737  # List of defined macros, add "-D" in front of each macro
738  my @ppkeys  = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{PPKEYS});
739  @ppkeys     = map {($tool{$tool_src_pp{DEFINE}} . $_)} @ppkeys;
740
741  # Add "-I" in front of each include directories
742  @inc        = map {($tool{$tool_src_pp{INCLUDE}} . $_)} @inc;
743
744  push @command, (@ppflags, @ppkeys, @inc, $self->base);
745
746  # Change to container directory of source file
747  my $old_cwd = $self->_chdir($self->dir());
748
749  # Execute the command, getting the output lines
750  my $verbose = $self->verbose;
751  my @outlines = &run_command (
752    \@command, METHOD => 'qx', PRINT => $verbose > 1, TIME => $verbose > 2,
753  );
754
755  # Change back to original directory
756  $self->_chdir($old_cwd);
757
758  return \@outlines;
759}
760
761# ------------------------------------------------------------------------------
762# SYNOPSIS
763#   $rules = %{ $self->get_rules };
764#
765# DESCRIPTION
766#   This method returns a reference to a hash in the following format:
767#     $rules = {
768#       target => {ACTION => action, DEP => [dependencies], ...},
769#       ...    => {...},
770#     };
771#   where the 1st rank keys are the available targets for building this source
772#   file, the second rank keys are ACTION and DEP. The value of ACTION is the
773#   action for building the target, which can be "COMPILE", "LOAD", "TOUCH",
774#   "CP" or "AR". The value of DEP is a refernce to an array containing a list
775#   of dependencies suitable for insertion into the Makefile.
776# ------------------------------------------------------------------------------
777
778sub get_rules {
779  my $self = shift;
780
781  my $rules;
782  my %outfile_ext = %{ $self->setting ('OUTFILE_EXT') };
783
784  if ($self->is_type_all (qw/SOURCE/)) {
785    # Source file
786    # --------------------------------------------------------------------------
787    # Determine whether the language of the source file is supported
788    my %tool_src = %{ $self->setting ('TOOL_SRC') };
789
790    return () unless $self->lang;
791
792    # Compile object
793    # --------------------------------------------------------------------------
794    if ($self->objbase) {
795      # Depends on the source file
796      my @dep = ($self->rule_src);
797
798      # Depends on the compiler flags flags-file
799      my @flags;
800      push @flags, ('FLAGS' )
801        if $self->flagsbase ('FLAGS' );
802      push @flags, ('PPKEYS')
803        if $self->flagsbase ('PPKEYS') and not $self->ppsrc;
804
805      push @dep, $self->flagsbase ($_) for (@flags);
806
807      # Source file dependencies
808      for my $name (sort keys %{ $self->dep }) {
809        # A Fortran 9X module, lower case object file name
810        if ($self->dep ($name) eq 'USE') {
811          (my $root = $name) =~ s/\.\w+$//;
812          push @dep, lc ($root) . $outfile_ext{OBJ};
813
814        # An include file
815        } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
816          push @dep, $name;
817        }
818      }
819
820      $rules->{$self->objbase} = {ACTION => 'COMPILE', DEP => \@dep};
821
822      # Touch flags-files
823      # ------------------------------------------------------------------------
824      for my $flag (@flags) {
825        next unless $self->flagsbase ($flag);
826
827        $rules->{$self->flagsbase ($flag)} = {
828          ACTION => 'TOUCH',
829          DEP    => [
830            $self->flagsbase ($tool_src{$self->lang}{$flag}, -2),
831          ],
832          DEST   => '$(FCM_FLAGSDIR)',
833        };
834      }
835    }
836
837    if ($self->exebase) {
838      # Link into an executable
839      # ------------------------------------------------------------------------
840      my @dep = ();
841      push @dep, $self->objbase               if $self->objbase;
842      push @dep, $self->flagsbase ('LD'     ) if $self->flagsbase ('LD'     );
843      push @dep, $self->flagsbase ('LDFLAGS') if $self->flagsbase ('LDFLAGS');
844
845      # Depends on BLOCKDATA program units, for Fortran programs
846      my %blockdata = %{ $self->setting ('BLD_BLOCKDATA') };
847      my @blkobj    = ();
848
849      if ($self->is_type_any (qw/FPP FORTRAN/) and keys %blockdata) {
850        # List of BLOCKDATA object files
851        if (exists $blockdata{$self->exebase}) {
852          @blkobj = split /\s+/, $blockdata{$self->exebase};
853
854        } elsif (exists $blockdata{''}) {
855          @blkobj = split /\s+/, $blockdata{''};
856        }
857
858        for my $name (@blkobj) {
859          (my $root = $name) =~ s/\.\w+$//;
860          $name = $root . $outfile_ext{OBJ};
861          push @dep, $root . $outfile_ext{DONE};
862        }
863      }
864
865      # Extra executable dependencies
866      my %exe_dep = %{ $self->setting ('BLD_DEP_EXE') };
867      if (keys %exe_dep) {
868        my @exe_deps;
869        if (exists $exe_dep{$self->exebase}) {
870          @exe_deps = split /\s+/, $exe_dep{$self->exebase};
871
872        } elsif (exists $exe_dep{''}) {
873          @exe_deps = $exe_dep{''} ? split (/\s+/, $exe_dep{''}) : ('');
874        }
875
876        my $pattern = '\\' . $outfile_ext{OBJ} . '$';
877
878        for my $name (@exe_deps) {
879          if ($name =~ /$pattern/) {
880            # Extra dependency is an object
881            (my $root = $name) =~ s/\.\w+$//;
882            push @dep, $root . $outfile_ext{DONE};
883
884          } else {
885            # Extra dependency is a sub-package
886            my $var;
887            if ($self->setting ('FCM_PCK_OBJECTS', $name)) {
888              # sub-package name contains unusual characters
889              $var = $self->setting ('FCM_PCK_OBJECTS', $name);
890
891            } else {
892              # sub-package name contains normal characters
893              $var = $name ? join ('__', ('OBJECTS', $name)) : 'OBJECTS';
894            }
895
896            push @dep, '$(' . $var . ')';
897          }
898        }
899      }
900
901      # Source file dependencies
902      for my $name (sort keys %{ $self->dep }) {
903        (my $root = $name) =~ s/\.\w+$//;
904
905        # Lowercase name for object dependency
906        $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
907
908        # Select "done" file extension
909        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
910          push @dep, $name . $outfile_ext{IDONE};
911
912        } else {
913          push @dep, $root . $outfile_ext{DONE};
914        }
915      }
916
917      $rules->{$self->exebase} = {
918        ACTION => 'LOAD', DEP => \@dep, BLOCKDATA => \@blkobj,
919      };
920
921      # Touch Linker flags-file
922      # ------------------------------------------------------------------------
923      for my $flag (qw/LD LDFLAGS/) {
924        $rules->{$self->flagsbase ($flag)} = {
925          ACTION => 'TOUCH',
926          DEP    => [$self->flagsbase ($flag, -2)],
927          DEST   => '$(FCM_FLAGSDIR)',
928        };
929      }
930
931    }
932
933    if ($self->donebase) {
934      # Touch done file
935      # ------------------------------------------------------------------------
936      my @dep = ($self->objbase);
937
938      for my $name (sort keys %{ $self->dep }) {
939        (my $root = $name) =~ s/\.\w+$//;
940
941        # Lowercase name for object dependency
942        $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
943
944        # Select "done" file extension
945        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
946          push @dep, $name . $outfile_ext{IDONE};
947
948        } else {
949          push @dep, $root . $outfile_ext{DONE};
950        }
951      }
952
953      $rules->{$self->donebase} = {
954        ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
955      };
956    }
957   
958    if ($self->interfacebase) {
959      # Interface target
960      # ------------------------------------------------------------------------
961      # Source file dependencies
962      my @dep = ();
963      for my $name (sort keys %{ $self->dep }) {
964        # Depends on Fortran 9X modules
965        push @dep, lc ($name) . $outfile_ext{OBJ}
966          if $self->dep ($name) eq 'USE';
967      }
968
969      $rules->{$self->interfacebase} = {ACTION => '', DEP => \@dep};
970    }
971
972  } elsif ($self->is_type_all ('INCLUDE')) {
973    # Copy include target
974    # --------------------------------------------------------------------------
975    my @dep = ($self->rule_src);
976
977    for my $name (sort keys %{ $self->dep }) {
978      # A Fortran 9X module, lower case object file name
979      if ($self->dep ($name) eq 'USE') {
980        (my $root = $name) =~ s/\.\w+$//;
981        push @dep, lc ($root) . $outfile_ext{OBJ};
982
983      # An include file
984      } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
985        push @dep, $name;
986      }
987    }
988
989    $rules->{$self->curbase} = {
990      ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_INCDIR)',
991    };
992
993    # Touch IDONE file
994    # --------------------------------------------------------------------------
995    if ($self->donebase) {
996      my @dep = ($self->rule_src);
997
998      for my $name (sort keys %{ $self->dep }) {
999        (my $root = $name) =~ s/\.\w+$//;
1000
1001        # Lowercase name for object dependency
1002        $root   = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
1003
1004        # Select "done" file extension
1005        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
1006          push @dep, $name . $outfile_ext{IDONE};
1007
1008        } else {
1009          push @dep, $root . $outfile_ext{DONE};
1010        }
1011      }
1012
1013      $rules->{$self->donebase} = {
1014        ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
1015      };
1016    }
1017
1018  } elsif ($self->is_type_any (qw/EXE SCRIPT/)) {
1019    # Copy executable file
1020    # --------------------------------------------------------------------------
1021    my @dep = ($self->rule_src);
1022
1023    # Depends on dummy copy file, if file is an "always build type"
1024    push @dep, $self->setting (qw/BLD_CPDUMMY/)
1025      if $self->is_type_any (split (
1026        /$FCM1::Config::DELIMITER_LIST/, $self->setting ('BLD_TYPE_ALWAYS_BUILD')
1027      ));
1028
1029    # Depends on other executable files
1030    for my $name (sort keys %{ $self->dep }) {
1031      push @dep, $name if $self->dep ($name) eq 'EXE';
1032    }
1033
1034    $rules->{$self->curbase} = {
1035      ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_BINDIR)',
1036    };
1037
1038  } elsif (@{ $self->children }) {
1039    # Targets for top level and package flags files and dummy dependencies
1040    # --------------------------------------------------------------------------
1041    my %tool_src   = %{ $self->setting ('TOOL_SRC') };
1042    my %flags_tool = (LD => '', LDFLAGS => '');
1043
1044    for my $key (keys %tool_src) {
1045      $flags_tool{$tool_src{$key}{FLAGS}} = $tool_src{$key}{COMMAND}
1046        if exists $tool_src{$key}{FLAGS};
1047
1048      $flags_tool{$tool_src{$key}{PPKEYS}} = ''
1049        if exists $tool_src{$key}{PPKEYS};
1050    }
1051
1052    for my $name (sort keys %flags_tool) {
1053      my @dep = $self->pkgname eq '' ? () : $self->flagsbase ($name, -2);
1054      push @dep, $self->flagsbase ($flags_tool{$name})
1055        if $self->pkgname eq '' and $flags_tool{$name};
1056
1057      $rules->{$self->flagsbase ($flags_tool{$name})} = {
1058        ACTION => 'TOUCH',
1059        DEST   => '$(FCM_FLAGSDIR)',
1060      } if $self->pkgname eq '' and $flags_tool{$name};
1061
1062      $rules->{$self->flagsbase ($name)} = {
1063        ACTION => 'TOUCH',
1064        DEP    => \@dep,
1065        DEST   => '$(FCM_FLAGSDIR)',
1066      };
1067    }
1068
1069    # Package object and library
1070    # --------------------------------------------------------------------------
1071    {
1072      my @dep;
1073      # Add objects from children
1074      for my $child (sort {$a->pkgname cmp $b->pkgname} @{ $self->children }) {
1075        push @dep, $child->rule_obj_var (1)
1076          if $child->libbase and $child->rules ($child->libbase);
1077        push @dep, $child->objbase
1078          if $child->cursrc and $child->objbase and
1079             not $child->is_type_any (qw/PROGRAM BLOCKDATA/);
1080      }
1081
1082      if (@dep) {
1083        $rules->{$self->libbase} = {ACTION => 'AR', DEP => \@dep};
1084      }
1085    }
1086
1087    # Package data files
1088    # --------------------------------------------------------------------------
1089    {
1090      my @dep;
1091      for my $child (@{ $self->children }) {
1092        push @dep, $child->rule_src if $child->src and not $child->type;
1093      }
1094
1095      if (@dep) {
1096        push @dep, $self->setting (qw/BLD_CPDUMMY/);
1097        $rules->{$self->etcbase} = {
1098          ACTION => 'CP_DATA', DEP => \@dep, DEST => '$(FCM_ETCDIR)',
1099        };
1100      }
1101    }
1102  }
1103
1104  return $rules;
1105}
1106
1107# ------------------------------------------------------------------------------
1108# SYNOPSIS
1109#   $value = $obj->get_setting ($setting[, @prefix]);
1110#
1111# DESCRIPTION
1112#   This method gets the correct $setting for the current source by following
1113#   its package name. If @prefix is set, get the setting with the given prefix.
1114# ------------------------------------------------------------------------------
1115
1116sub get_setting {
1117  my ($self, $setting, @prefix) = @_;
1118
1119  my $val;
1120  for my $name (reverse @{ $self->pkgnames }) {
1121    my @names = split /__/, $name;
1122    $val = $self->setting ($setting, join ('__', (@prefix, @names)));
1123
1124    $val = $self->setting ($setting, join ('__', (@prefix, @names)))
1125      if (not defined $val) and @names and $names[-1] =~ s/\.[^\.]+$//;
1126    last if defined $val;
1127  }
1128
1129  return $val;
1130}
1131
1132# ------------------------------------------------------------------------------
1133# SYNOPSIS
1134#   $type = $self->get_type();
1135#
1136# DESCRIPTION
1137#   This method determines whether the source is a type known to the
1138#   build system. If so, it returns the type flags delimited by "::".
1139# ------------------------------------------------------------------------------
1140
1141sub get_type {
1142  my $self = shift();
1143  my @IGNORE_LIST
1144    = split(/$FCM1::Config::DELIMITER_LIST/, $self->setting('INFILE_IGNORE'));
1145  if (grep {$self->curbase() eq $_} @IGNORE_LIST) {
1146    return q{};
1147  }
1148  # User defined
1149  my $type = $self->setting('BLD_TYPE', $self->pkgname());
1150  # Extension
1151  if (!defined($type)) {
1152    my $ext = $self->curext() ? substr($self->curext(), 1) : q{};
1153    $type = $self->setting('INFILE_EXT', $ext);
1154  }
1155  # Pattern of name
1156  if (!defined($type)) {
1157    my %NAME_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_PAT')};
1158    PATTERN:
1159    while (my ($pattern, $value) = each(%NAME_PATTERN_TO_TYPE_HASH)) {
1160      if ($self->curbase() =~ $pattern) {
1161        $type = $value;
1162        last PATTERN;
1163      }
1164    }
1165  }
1166  # Pattern of #! line
1167  if (!defined($type) && -s $self->cursrc() && -T _) {
1168    my $handle = _open($self->cursrc());
1169    my $line = readline($handle);
1170    close($handle);
1171    my %SHEBANG_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_TXT')};
1172    PATTERN:
1173    while (my ($pattern, $value) = each(%SHEBANG_PATTERN_TO_TYPE_HASH)) {
1174      if ($line =~ qr{^\#!.*$pattern}msx) {
1175        $type = $value;
1176        last PATTERN;
1177      }
1178    }
1179  }
1180  if (!$type) {
1181    return $type;
1182  }
1183  # Extra type information for selected file types
1184  my %EXTRA_FOR = (
1185    qr{\b (?:FORTRAN|FPP) \b}msx => \&_get_type_extra_for_fortran,
1186    qr{\b C \b}msx               => \&_get_type_extra_for_c,
1187  );
1188  EXTRA:
1189  while (my ($key, $code_ref) = each(%EXTRA_FOR)) {
1190    if ($type =~ $key) {
1191      my $handle = _open($self->cursrc());
1192      LINE:
1193      while (my $line = readline($handle)) {
1194        my $extra = $code_ref->($line);
1195        if ($extra) {
1196          $type .= $FCM1::Config::DELIMITER . $extra;
1197          last LINE;
1198        }
1199      }
1200      close($handle);
1201      last EXTRA;
1202    }
1203  }
1204  return $type;
1205}
1206
1207sub _get_type_extra_for_fortran {
1208  my ($match) = $_[0] =~ qr{\A \s* (PROGRAM|MODULE|BLOCK\s*DATA) \b}imsx;
1209  if (!$match) {
1210    return;
1211  }
1212  $match =~ s{\s}{}g;
1213  uc($match)
1214}
1215
1216sub _get_type_extra_for_c {
1217  ($_[0] =~ qr{int\s+main\s*\(}msx) ? 'PROGRAM' : undef;
1218}
1219
1220# ------------------------------------------------------------------------------
1221# SYNOPSIS
1222#   $flag = $obj->is_in_package ($name);
1223#
1224# DESCRIPTION
1225#   This method returns true if current package is in the package $name.
1226# ------------------------------------------------------------------------------
1227
1228sub is_in_package {
1229  my ($self, $name) = @_;
1230 
1231  my $return = 0;
1232  for (@{ $self->pkgnames }) {
1233    next unless /^$name(?:\.\w+)?$/;
1234    $return = 1;
1235    last;
1236  }
1237
1238  return $return;
1239}
1240
1241# ------------------------------------------------------------------------------
1242# SYNOPSIS
1243#   $flag = $obj->is_type_all ($arg, ...);
1244#   $flag = $obj->is_type_any ($arg, ...);
1245#
1246# DESCRIPTION
1247#   This method returns a flag for the following:
1248#     is_type_all - does type match all of the arguments?
1249#     is_type_any - does type match any of the arguments?
1250# ------------------------------------------------------------------------------
1251
1252for my $name ('all', 'any') {
1253  no strict 'refs';
1254
1255  my $subname = 'is_type_' . $name;
1256
1257  *$subname = sub {
1258    my ($self, @intypes) = @_;
1259
1260    my $rc = 0;
1261    if ($self->type) {
1262      my %types = map {($_, 1)} split /$FCM1::Config::DELIMITER/, $self->type;
1263
1264      for my $intype (@intypes) {
1265        $rc = exists $types{$intype};
1266        last if ($name eq 'all' and not $rc) or ($name eq 'any' and $rc);
1267      }
1268    }
1269
1270    return $rc;
1271  }
1272}
1273
1274# ------------------------------------------------------------------------------
1275# SYNOPSIS
1276#   $string = $obj->rule_obj_var ([$read]);
1277#
1278# DESCRIPTION
1279#   This method returns a string containing the make rule object variable for
1280#   the current package. If $read is set, return $($string)
1281# ------------------------------------------------------------------------------
1282
1283sub rule_obj_var {
1284  my ($self, $read) = @_;
1285
1286  my $return;
1287  if ($self->setting ('FCM_PCK_OBJECTS', $self->pkgname)) {
1288    # Package name registered in unusual list
1289    $return = $self->setting ('FCM_PCK_OBJECTS', $self->pkgname);
1290
1291  } else {
1292    # Package name not registered in unusual list
1293    $return = $self->pkgname
1294              ? join ('__', ('OBJECTS', $self->pkgname)) : 'OBJECTS';
1295  }
1296
1297  $return = $read ? '$(' . $return . ')' : $return;
1298
1299  return $return;
1300}
1301
1302# ------------------------------------------------------------------------------
1303# SYNOPSIS
1304#   $string = $obj->rule_src ();
1305#
1306# DESCRIPTION
1307#   This method returns a string containing the location of the source file
1308#   relative to the build root. This string will be suitable for use in a
1309#   "Make" rule file for FCM.
1310# ------------------------------------------------------------------------------
1311
1312sub rule_src {
1313  my $self = shift;
1314
1315  my $return = $self->cursrc;
1316  LABEL: for my $name (qw/SRC PPSRC/) {
1317    for my $i (0 .. @{ $self->setting ('PATH', $name) } - 1) {
1318      my $dir = $self->setting ('PATH', $name)->[$i];
1319      next unless index ($self->cursrc, $dir) == 0;
1320
1321      $return = File::Spec->catfile (
1322        '$(FCM_' . $name . 'DIR' . ($i ? $i : '') . ')',
1323        File::Spec->abs2rel ($self->cursrc, $dir),
1324      );
1325      last LABEL;
1326    }
1327  }
1328
1329  return $return;
1330}
1331
1332# ------------------------------------------------------------------------------
1333# SYNOPSIS
1334#   $rc = $obj->write_lib_dep_excl ();
1335#
1336# DESCRIPTION
1337#   This method writes a set of exclude dependency configurations for the
1338#   library of this package.
1339# ------------------------------------------------------------------------------
1340
1341sub write_lib_dep_excl {
1342  my $self = shift();
1343  if (!find_file_in_path($self->libbase(), $self->setting(qw/PATH LIB/))) {
1344    return 0;
1345  }
1346
1347  my $ETC_DIR = $self->setting(qw/PATH ETC/)->[0];
1348  my $CFG_EXT = $self->setting(qw/OUTFILE_EXT CFG/);
1349  my $LABEL_OF_EXCL_DEP = $self->cfglabel('BLD_DEP_EXCL');
1350  my @SETTINGS = (
1351       #dependency   #source file type list       #dependency name function
1352       ['H'        , [qw{INCLUDE CPP          }], sub {$_[0]->base()}         ],
1353       ['INTERFACE', [qw{INCLUDE INTERFACE    }], sub {$_[0]->base()}         ],
1354       ['INC'      , [qw{INCLUDE              }], sub {$_[0]->base()}         ],
1355       ['USE'      , [qw{SOURCE FORTRAN MODULE}], sub {$_[0]->root()}         ],
1356       ['INTERFACE', [qw{SOURCE FORTRAN       }], sub {$_[0]->interfacebase()}],
1357       ['OBJ'      , [qw{SOURCE               }], sub {$_[0]->root()}         ],
1358  );
1359
1360  my $cfg = FCM1::CfgFile->new();
1361  my @stack = ($self);
1362  NODE:
1363  while (my $node = pop(@stack)) {
1364    # Is a directory
1365    if (@{$node->children()}) {
1366      push(@stack, reverse(@{$node->children()}));
1367      next NODE;
1368    }
1369    # Is a typed file
1370    if (
1371          $node->cursrc()
1372      &&  $node->type()
1373      &&  !$node->is_type_any(qw{PROGRAM BLOCKDATA})
1374    ) {
1375      for (@SETTINGS) {
1376        my ($key, $type_list_ref, $name_func_ref) = @{$_};
1377        my $name = $name_func_ref->($node);
1378        if ($name && $node->is_type_all(@{$type_list_ref})) {
1379          push(
1380            @{$cfg->lines()},
1381            FCM1::CfgLine->new(
1382              label => $LABEL_OF_EXCL_DEP,
1383              value => $key . $FCM1::Config::DELIMITER . $name,
1384            ),
1385          );
1386          next NODE;
1387        }
1388      }
1389    }
1390  }
1391
1392  # Write to configuration file
1393  $cfg->print_cfg(
1394    File::Spec->catfile($ETC_DIR, $self->libbase('lib', $CFG_EXT)),
1395  );
1396}
1397
1398# ------------------------------------------------------------------------------
1399# SYNOPSIS
1400#   $string = $obj->write_rules ();
1401#
1402# DESCRIPTION
1403#   This method returns a string containing the "Make" rules for building the
1404#   source file.
1405# ------------------------------------------------------------------------------
1406
1407sub write_rules {
1408  my $self  = shift;
1409  my $mk    = '';
1410
1411  for my $target (sort keys %{ $self->rules }) {
1412    my $rule = $self->rules ($target);
1413    next unless defined ($rule->{ACTION});
1414
1415    if ($rule->{ACTION} eq 'AR') {
1416      my $var = $self->rule_obj_var;
1417      $mk .= ($var eq 'OBJECTS' ? 'export ' : '') . $var . ' =';
1418      $mk .= ' ' . join (' ', @{ $rule->{DEP} });
1419      $mk .= "\n\n";
1420    }
1421
1422    $mk .= $target . ':';
1423   
1424    if ($rule->{ACTION} eq 'AR') {
1425      $mk .= ' ' . $self->rule_obj_var (1);
1426
1427    } else {
1428      for my $dep (@{ $rule->{DEP} }) {
1429        $mk .= ' ' . $dep;
1430      }
1431    }
1432
1433    $mk .= "\n";
1434
1435    if (exists $rule->{ACTION}) {
1436      if ($rule->{ACTION} eq 'AR') {
1437        $mk .= "\t" . 'fcm_internal archive $@ $^' . "\n";
1438
1439      } elsif ($rule->{ACTION} eq 'CP') {
1440        $mk .= "\t" . 'cp $< ' . $rule->{DEST} . "\n";
1441        $mk .= "\t" . 'chmod u+w ' .
1442               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1443
1444      } elsif ($rule->{ACTION} eq 'CP_DATA') {
1445        $mk .= "\t" . 'cp $^ ' . $rule->{DEST} . "\n";
1446        $mk .= "\t" . 'touch ' .
1447               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1448
1449      } elsif ($rule->{ACTION} eq 'COMPILE') {
1450        if ($self->lang) {
1451          $mk .= "\t" . 'fcm_internal compile:' . substr ($self->lang, 0, 1) .
1452                 ' ' . $self->pkgnames->[-2] . ' $< $@';
1453          $mk .= ' 1' if ($self->flagsbase ('PPKEYS') and not $self->ppsrc);
1454          $mk .= "\n";
1455        }
1456
1457      } elsif ($rule->{ACTION} eq 'LOAD') {
1458        if ($self->lang) {
1459          $mk .= "\t" . 'fcm_internal load:' . substr ($self->lang, 0, 1) .
1460                 ' ' . $self->pkgnames->[-2] . ' $< $@';
1461          $mk .= ' ' . join (' ', @{ $rule->{BLOCKDATA} })
1462            if @{ $rule->{BLOCKDATA} };
1463          $mk .= "\n";
1464        }
1465
1466      } elsif ($rule->{ACTION} eq 'TOUCH') {
1467        $mk .= "\t" . 'touch ' .
1468               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1469      }
1470    }
1471
1472    $mk .= "\n";
1473  }
1474
1475  return $mk;
1476}
1477
1478# Wraps "chdir". Returns old directory.
1479sub _chdir {
1480  my ($self, $dir) = @_;
1481  my $old_cwd = cwd();
1482  $self->_event('CHDIR', $dir);
1483  chdir($dir) || croak(sprintf($ERR_MESS_OF{CHDIR}, $dir));
1484  $old_cwd;
1485}
1486
1487# Wraps an event.
1488sub _event {
1489  my ($self, $key, @args) = @_;
1490  my ($format, $level) = @{$EVENT_SETTING_OF{$key}};
1491  $level ||= 1;
1492  if ($self->verbose() >= $level) {
1493    printf($format . ".\n", @args);
1494  }
1495}
1496
1497# Wraps "open".
1498sub _open {
1499  my ($path, $mode) = @_;
1500  $mode ||= '<';
1501  open(my $handle, $mode, $path) || croak(sprintf($ERR_MESS_OF{OPEN}, $path, $!));
1502  $handle;
1503}
1504
1505# ------------------------------------------------------------------------------
1506
15071;
1508
1509__END__
Note: See TracBrowser for help on using the repository browser.