# ------------------------------------------------------------------------------
# NAME
#   Fcm::BuildSrc
#
# DESCRIPTION
#   This is a class to group functionalities of source in a build.
#
# COPYRIGHT
#   (C) Crown copyright Met Office. All rights reserved.
#   For further details please refer to the file COPYRIGHT.txt
#   which you should have received as part of this distribution.
# ------------------------------------------------------------------------------

use strict;
use warnings;

package Fcm::BuildSrc;
use base qw{Fcm::Base};

use Carp qw{croak};
use Cwd qw{cwd};
use Fcm::Build::Fortran;
use Fcm::CfgFile;
use Fcm::CfgLine;
use Fcm::Config;
use Fcm::Timer qw{timestamp_command};
use Fcm::Util qw{find_file_in_path run_command};
use File::Basename qw{basename dirname};
use File::Spec;

# List of scalar property methods for this class
my @scalar_properties = (
  'children',   # list of children packages
  'is_updated', # is this source (or its associated settings) updated?
  'mtime',      # modification time of src
  'ppmtime',    # modification time of ppsrc
  'ppsrc',      # full path of the pre-processed source
  'pkgname',    # package name of the source
  'progname',   # program unit name in the source
  'src',        # full path of the source
  'type',       # type of the source
);

# List of hash property methods for this class
my @hash_properties = (
  'dep',   # dependencies
  'ppdep', # pre-process dependencies
  'rules', # make rules
);

# Error message formats
my %ERR_MESS_OF = (
  CHDIR       => '%s: cannot change directory (%s), abort',
  OPEN        => '%s: cannot open (%s), abort',
  CLOSE_PIPE  => '%s: failed (%d), abort',
);

# Event message formats and levels
my %EVENT_SETTING_OF = (
  CHDIR            => ['%s: change directory'                   , 2],
  F_INTERFACE_NONE => ['%s: Fortran interface generation is off', 3],
  GET_DEPENDENCY   => ['%s: %d line(s), %d auto dependency(ies)', 3],
);

my %RE_OF = (
  F_PREFIX => qr{
    (?:
      (?:ELEMENTAL|PURE(?:\s+RECURSIVE)?|RECURSIVE(?:\s+PURE)?)
      \s+
    )?
  }imsx,
  F_SPEC => qr{
    (?:
      (?:CHARACTER|COMPLEX|DOUBLE\s*PRECISION|INTEGER|LOGICAL|REAL|TYPE)
      (?: \s* \( .+ \) | \s* \* \d+ \s*)??
      \s+
    )?
  }imsx,
);

{
  # Returns a singleton instance of Fcm::Build::Fortran.
  my $FORTRAN_UTIL;
  sub _get_fortran_util {
    $FORTRAN_UTIL ||= Fcm::Build::Fortran->new();
    return $FORTRAN_UTIL;
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $obj = Fcm::BuildSrc->new (%args);
#
# DESCRIPTION
#   This method constructs a new instance of the Fcm::BuildSrc class. See
#   above for allowed list of properties. (KEYS should be in uppercase.)
# ------------------------------------------------------------------------------

sub new {
  my ($class, %args) = @_;
  my $self = bless(Fcm::Base->new(%args), $class);
  for my $key (@scalar_properties, @hash_properties) {
    $self->{$key}
      = exists($args{uc($key)}) ? $args{uc($key)}
      :                           undef
      ;
  }
  $self;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->X;
#   $obj->X ($value);
#
# DESCRIPTION
#   Details of these properties are explained in @scalar_properties.
# ------------------------------------------------------------------------------

for my $name (@scalar_properties) {
  no strict 'refs';

  *$name = sub {
    my $self = shift;

    # Argument specified, set property to specified argument
    if (@_) {
      $self->{$name} = $_[0];

      if ($name eq 'ppsrc') {
        $self->ppmtime (undef);

      } elsif ($name eq 'src') {
        $self->mtime (undef);
      }
    }

    # Default value for property
    if (not defined $self->{$name}) {
      if ($name eq 'children') {
        # Reference to an empty array
        $self->{$name} = [];
        
      } elsif ($name =~ /^(?:is_cur|pkgname|ppsrc|src)$/) {
        # Empty string
        $self->{$name} = '';
        
      } elsif ($name eq 'mtime') {
        # Modification time
        $self->{$name} = (stat $self->src)[9] if $self->src;
        
      } elsif ($name eq 'ppmtime') {
        # Modification time
        $self->{$name} = (stat $self->ppsrc)[9] if $self->ppsrc;
        
      } elsif ($name eq 'type') {
        # Attempt to get the type if src is set
        $self->{$name} = $self->get_type if $self->src;
      }
    }

    return $self->{$name};
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   %hash = %{ $obj->X () };
#   $obj->X (\%hash);
#
#   $value = $obj->X ($index);
#   $obj->X ($index, $value);
#
# DESCRIPTION
#   Details of these properties are explained in @hash_properties.
#
#   If no argument is set, this method returns a hash containing a list of
#   objects. If an argument is set and it is a reference to a hash, the objects
#   are replaced by the the specified hash.
#
#   If a scalar argument is specified, this method returns a reference to an
#   object, if the indexed object exists or undef if the indexed object does
#   not exist. If a second argument is set, the $index element of the hash will
#   be set to the value of the argument.
# ------------------------------------------------------------------------------

for my $name (@hash_properties) {
  no strict 'refs';

  *$name = sub {
    my ($self, $arg1, $arg2) = @_;

    # Ensure property is defined as a reference to a hash
    if (not defined $self->{$name}) {
      if ($name eq 'rules') {
        $self->{$name} = $self->get_rules;

      } else {
        $self->{$name} = {};
      }
    }

    # Argument 1 can be a reference to a hash or a scalar index
    my ($index, %hash);

    if (defined $arg1) {
      if (ref ($arg1) eq 'HASH') {
        %hash = %$arg1;

      } else {
        $index = $arg1;
      }
    }

    if (defined $index) {
      # A scalar index is defined, set and/or return the value of an element
      $self->{$name}{$index} = $arg2 if defined $arg2;

      return (
        exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
      );

    } else {
      # A scalar index is not defined, set and/or return the hash
      $self->{$name} = \%hash if defined $arg1;
      return $self->{$name};
    }
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->X;
#   $obj->X ($value);
#
# DESCRIPTION
#   This method returns/sets property X, all derived from src, where X is:
#     base  - (read-only) basename of src
#     dir   - (read-only) dirname of src
#     ext   - (read-only) file extension of src
#     root  - (read-only) basename of src without the file extension
# ------------------------------------------------------------------------------

sub base {
  return &basename ($_[0]->src);
}

# ------------------------------------------------------------------------------

sub dir {
  return &dirname ($_[0]->src);
}

# ------------------------------------------------------------------------------

sub ext {
  return substr $_[0]->base, length ($_[0]->root);
}

# ------------------------------------------------------------------------------

sub root {
  (my $root = $_[0]->base) =~ s/\.\w+$//;
  return $root;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->X;
#   $obj->X ($value);
#
# DESCRIPTION
#   This method returns/sets property X, all derived from ppsrc, where X is:
#     ppbase  - (read-only) basename of ppsrc
#     ppdir   - (read-only) dirname of ppsrc
#     ppext   - (read-only) file extension of ppsrc
#     pproot  - (read-only) basename of ppsrc without the file extension
# ------------------------------------------------------------------------------

sub ppbase {
  return &basename ($_[0]->ppsrc);
}

# ------------------------------------------------------------------------------

sub ppdir {
  return &dirname ($_[0]->ppsrc);
}

# ------------------------------------------------------------------------------

sub ppext {
  return substr $_[0]->ppbase, length ($_[0]->pproot);
}

# ------------------------------------------------------------------------------

sub pproot {
  (my $root = $_[0]->ppbase) =~ s/\.\w+$//;
  return $root;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->X;
#
# DESCRIPTION
#   This method returns/sets property X, derived from src or ppsrc, where X is:
#     curbase  - (read-only) basename of cursrc
#     curdir   - (read-only) dirname of cursrc
#     curext   - (read-only) file extension of cursrc
#     curmtime - (read-only) modification time of cursrc
#     curroot  - (read-only) basename of cursrc without the file extension
#     cursrc   - ppsrc or src
# ------------------------------------------------------------------------------

for my $name (qw/base dir ext mtime root src/) {
  no strict 'refs';

  my $subname = 'cur' . $name;

  *$subname = sub {
    my $self = shift;
    my $method = $self->ppsrc ? 'pp' . $name : $name;
    return $self->$method (@_);
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $base = $obj->X ();
#
# DESCRIPTION
#   This method returns a basename X for the source, where X is:
#     donebase      - "done" file name
#     etcbase       - target for copying data files
#     exebase       - executable name for source containing a main program
#     interfacebase - Fortran interface file name
#     libbase       - library file name
#     objbase       - object name for source containing compilable source
#   If the source file contains a compilable procedure, this method returns
#   the name of the object file.
# ------------------------------------------------------------------------------

sub donebase {
  my $self   = shift;

  my $return;
  if ($self->is_type_all ('SOURCE')) {
    if ($self->objbase and not $self->is_type_all ('PROGRAM')) {
      $return = ($self->progname ? $self->progname : lc ($self->curroot)) .
                $self->setting (qw/OUTFILE_EXT DONE/);
    }

  } elsif ($self->is_type_all ('INCLUDE')) {
    $return = $self->curbase . $self->setting (qw/OUTFILE_EXT IDONE/);
  }

  return $return;
}

# ------------------------------------------------------------------------------

sub etcbase {
  my $self = shift;

  my $return = @{ $self->children }
               ? $self->pkgname . $self->setting (qw/OUTFILE_EXT ETC/)
               : undef;

  return $return;
}

# ------------------------------------------------------------------------------

sub exebase {
  my $self = shift;

  my $return;
  if ($self->objbase and $self->is_type_all ('PROGRAM')) {
    if ($self->setting ('BLD_EXE_NAME', $self->curroot)) {
      $return = $self->setting ('BLD_EXE_NAME', $self->curroot);

    } else {
      $return = $self->curroot . $self->setting (qw/OUTFILE_EXT EXE/);
    }
  }

  return $return;
}

# ------------------------------------------------------------------------------

sub interfacebase {
  my $self = shift();
  if (
        uc($self->get_setting(qw/TOOL GENINTERFACE/)) ne 'NONE'
    &&  $self->progname()
    &&  $self->is_type_all(qw/SOURCE/)
    &&  $self->is_type_any(qw/FORTRAN9X FPP9X/)
    &&  !$self->is_type_any(qw/PROGRAM MODULE BLOCKDATA/)
  ) {
    my $flag = lc($self->get_setting(qw/TOOL INTERFACE/));
    my $ext  = $self->setting(qw/OUTFILE_EXT INTERFACE/);

    return (($flag eq 'program' ? $self->progname() : $self->curroot()) . $ext);
  }
  return;
}

# ------------------------------------------------------------------------------

sub objbase {
  my $self = shift;

  my $return;

  if ($self->is_type_all ('SOURCE')) {
    my $ext = $self->setting (qw/OUTFILE_EXT OBJ/);

    if ($self->is_type_any (qw/FORTRAN FPP/)) {
      $return = lc ($self->progname) . $ext if $self->progname;

    } else {
      $return = lc ($self->curroot) . $ext;
    }
  }

  return $return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->flagsbase ($flag, [$index,]);
#
# DESCRIPTION
#   This method returns the property flagsbase (derived from pkgname) the base
#   name of the flags-file (to indicate changes in a particular build tool) for
#   $flag, which can have the value:
#     *FLAGS  - compiler flags flags-file
#     *PPKEYS - pre-processor keys (i.e. macro definitions) flags-file
#     LD      - linker flags-file
#     LDFLAGS - linker flags flags-file
#   If $index is set, the $index'th element in pkgnames is used for the package
#   name.
# ------------------------------------------------------------------------------

sub flagsbase {
  my ($self, $flag, $index) = @_;

  (my $pkg = $index ? $self->pkgnames->[$index] : $self->pkgname) =~ s/\.\w+$//;

  if ($self->is_type_all ('SOURCE')) {
    if ($flag eq 'FLAGS' or $flag eq 'PPKEYS' and $self->lang) {
      my %tool_src = %{ $self->setting ('TOOL_SRC') };
      $flag = $tool_src{$self->lang}{$flag} ? $tool_src{$self->lang}{$flag} : '';
    }
  }

  if ($flag) {
    return join ('__', ($flag, $pkg ? $pkg : ())) .
           $self->setting (qw/OUTFILE_EXT FLAGS/);

  } else {
    return undef;
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->libbase ([$prefix], [$suffix]);
#
# DESCRIPTION
#   This method returns the property libbase (derived from pkgname) the base
#   name of the library archive. $prefix and $suffix defaults to 'lib' and '.a'
#   respectively.
# ------------------------------------------------------------------------------

sub libbase {
  my ($self, $prefix, $suffix) = @_;
  $prefix ||= 'lib';
  $suffix ||= $self->setting(qw/OUTFILE_EXT LIB/);
  if ($self->src()) { # applies to directories only
    return;
  }
  my $name = $self->setting('BLD_LIB', $self->pkgname());
  if (!defined($name)) {
    $name = $self->pkgname();
  }
  $prefix . $name . $suffix;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->lang ([$setting]);
#
# DESCRIPTION
#   This method returns the property lang (derived from type) the programming
#   language name if type matches one supported in the TOOL_SRC setting. If
#   $setting is specified, use $setting instead of TOOL_SRC.
# ------------------------------------------------------------------------------

sub lang {
  my ($self, $setting) = @_;

  my @keys = keys %{ $self->setting ($setting ? $setting : 'TOOL_SRC') };

  my $return = undef;
  for my $key (@keys) {
    next unless $self->is_type_all ('SOURCE', $key);
    $return = $key;
    last;
  }

  return $return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->pkgnames;
#
# DESCRIPTION
#   This method returns a list of container packages, derived from pkgname:
# ------------------------------------------------------------------------------

sub pkgnames {
  my $self = shift;

  my $return = [];
  if ($self->pkgname) {
    my @names = split (/__/, $self->pkgname);

    for my $i (0 .. $#names) {
      push @$return, join ('__', (@names[0 .. $i]));
    }

    unshift @$return, '';
  }

  return $return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   %dep = %{$obj->get_dep()};
#   %dep = %{$obj->get_dep($flag)};
#
# DESCRIPTION
#   This method scans the current source file for dependencies and returns the
#   dependency hash (keys = dependencies, values = dependency types). If $flag
#   is specified, the config setting for $flag is used to determine the types of
#   types. Otherwise, those specified in 'BLD_TYPE_DEP' is used.
# ------------------------------------------------------------------------------

sub get_dep {
  my ($self, $flag) = @_;
  # Work out list of exclude for this file, using its sub-package name
  my %EXCLUDE_SET = map {($_, 1)} @{$self->get_setting('BLD_DEP_EXCL')};
  # Determine what dependencies are supported by this known type
  my %DEP_TYPE_OF = %{$self->setting($flag ? $flag : 'BLD_TYPE_DEP')};
  my %PATTERN_OF = %{$self->setting('BLD_DEP_PATTERN')};
  my @dep_types = ();
  if (!$self->get_setting('BLD_DEP_N')) {
    DEP_TYPE:
    while (my ($key, $dep_type_string) = each(%DEP_TYPE_OF)) {
      # Check if current file is a type of file requiring dependency scan
      if (!$self->is_type_all($key)) {
        next DEP_TYPE;
      }
      # Get list of dependency type for this file
      for my $dep_type (split(/$Fcm::Config::DELIMITER/, $dep_type_string)) {
        if (exists($PATTERN_OF{$dep_type}) && !exists($EXCLUDE_SET{$dep_type})) {
          push(@dep_types, $dep_type);
        }
      }
    }
  }

  # Automatic dependencies
  my %dep_of;
  my $can_get_symbol # Also scan for program unit name in Fortran source
      =  !$flag
      && $self->is_type_all('SOURCE')
      && $self->is_type_any(qw/FPP FORTRAN/)
      ;
  my $has_read_file;
  if ($can_get_symbol || @dep_types) {
    my $handle = _open($self->cursrc());
    LINE:
    while (my $line = readline($handle)) {
      chomp($line);
      if ($line =~ qr{\A \s* \z}msx) { # empty lines
        next LINE;
      }
      if ($can_get_symbol) {
        my $symbol = _get_dep_symbol($line);
        if ($symbol) {
          $self->progname($symbol);
          $can_get_symbol = 0;
          next LINE;
        }
      }
      DEP_TYPE:
      for my $dep_type (@dep_types) {
        my ($match) = $line =~ /$PATTERN_OF{$dep_type}/i;
        if (!$match) {
          next DEP_TYPE;
        }
        # $match may contain multiple items delimited by space
        for my $item (split(qr{\s+}msx, $match)) {
          my $key = uc($dep_type . $Fcm::Config::DELIMITER . $item);
          if (!exists($EXCLUDE_SET{$key})) {
            $dep_of{$item} = $dep_type;
          }
        }
        next LINE;
      }
    }
    $self->_event('GET_DEPENDENCY', $self->pkgname(), $., scalar(keys(%dep_of)));
    close($handle);
    $has_read_file = 1;
  }

  # Manual dependencies
  my $manual_deps_ref
      = $self->setting('BLD_DEP' . ($flag ? '_PP' : ''), $self->pkgname());
  if (defined($manual_deps_ref)) {
    for (@{$manual_deps_ref}) {
      my ($dep_type, $item) = split(/$Fcm::Config::DELIMITER/, $_, 2);
      $dep_of{$item} = $dep_type;
    }
  }

  return ($has_read_file, \%dep_of);
}

# Returns, if possible, the program unit declared in the $line.
sub _get_dep_symbol {
  my $line = shift();
  for my $pattern (
    qr{\A \s* $RE_OF{F_PREFIX} SUBROUTINE              \s+ ([A-Za-z]\w*)}imsx,
    qr{\A \s* MODULE (?!\s+PROCEDURE)                  \s+ ([A-Za-z]\w*)}imsx,
    qr{\A \s* PROGRAM                                  \s+ ([A-Za-z]\w*)}imsx,
    qr{\A \s* $RE_OF{F_PREFIX} $RE_OF{F_SPEC} FUNCTION \s+ ([A-Za-z]\w*)}imsx,
    qr{\A \s* BLOCK\s*DATA                             \s+ ([A-Za-z]\w*)}imsx,
  ) {
    my ($match) = $line =~ $pattern;
    if ($match) {
      return lc($match);
    }
  }
  return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   @out = @{ $obj->get_fortran_interface () };
#
# DESCRIPTION
#   This method invokes the Fortran interface block generator to generate
#   an interface block for the current source file. It returns a reference to
#   an array containing the lines of the interface block.
# ------------------------------------------------------------------------------

sub get_fortran_interface {
  my $self = shift();
  my %ACTION_OF = (
    q{}    => \&_get_fortran_interface_by_internal_code,
    f90aib => \&_get_fortran_interface_by_f90aib,
    none   => sub {$self->_event('F_INTERFACE_NONE', $self->root()); []},
  );
  my $key = lc($self->get_setting(qw/TOOL GENINTERFACE/));
  if (!$key || !exists($ACTION_OF{$key})) {
    $key = q{};
  }
  $ACTION_OF{$key}->($self->cursrc());
}

# Generates Fortran interface block using "f90aib".
sub _get_fortran_interface_by_f90aib {
  my $path = shift();
  my $command = sprintf(q{f90aib <'%s' 2>'%s'}, $path, File::Spec->devnull());
  my $pipe = _open($command, '-|');
  my @lines = readline($pipe);
  close($pipe) || croak($ERR_MESS_OF{CLOSE_PIPE}, $command, $?);
  \@lines;
}

# Generates Fortran interface block using internal code.
sub _get_fortran_interface_by_internal_code {
  my $path = shift();
  my $handle = _open($path);
  my @lines = _get_fortran_util()->extract_interface($handle);
  close($handle);
  \@lines;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   @out = @{ $obj->get_pre_process () };
#
# DESCRIPTION
#   This method invokes the pre-processor on the source file and returns a
#   reference to an array containing the lines of the pre-processed source on
#   success.
# ------------------------------------------------------------------------------

sub get_pre_process {
  my $self = shift;

  # Supported source files
  my $lang = $self->lang ('TOOL_SRC_PP');
  return unless $lang;

  # List of include directories
  my @inc = @{ $self->setting (qw/PATH INC/) };

  # Build the pre-processor command according to file type
  my %tool        = %{ $self->setting ('TOOL') };
  my %tool_src_pp = %{ $self->setting ('TOOL_SRC_PP', $lang) };

  # The pre-processor command and its options
  my @command = ($tool{$tool_src_pp{COMMAND}});
  my @ppflags = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{FLAGS});

  # List of defined macros, add "-D" in front of each macro
  my @ppkeys  = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{PPKEYS});
  @ppkeys     = map {($tool{$tool_src_pp{DEFINE}} . $_)} @ppkeys;

  # Add "-I" in front of each include directories
  @inc        = map {($tool{$tool_src_pp{INCLUDE}} . $_)} @inc;

  push @command, (@ppflags, @ppkeys, @inc, $self->base);

  # Change to container directory of source file
  my $old_cwd = $self->_chdir($self->dir());

  # Execute the command, getting the output lines
  my $verbose = $self->verbose;
  my @outlines = &run_command (
    \@command, METHOD => 'qx', PRINT => $verbose > 1, TIME => $verbose > 2,
  );

  # Change back to original directory
  $self->_chdir($old_cwd);

  return \@outlines;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rules = %{ $self->get_rules };
#
# DESCRIPTION
#   This method returns a reference to a hash in the following format:
#     $rules = {
#       target => {ACTION => action, DEP => [dependencies], ...},
#       ...    => {...},
#     };
#   where the 1st rank keys are the available targets for building this source
#   file, the second rank keys are ACTION and DEP. The value of ACTION is the
#   action for building the target, which can be "COMPILE", "LOAD", "TOUCH",
#   "CP" or "AR". The value of DEP is a refernce to an array containing a list
#   of dependencies suitable for insertion into the Makefile.
# ------------------------------------------------------------------------------

sub get_rules {
  my $self = shift;

  my $rules;
  my %outfile_ext = %{ $self->setting ('OUTFILE_EXT') };

  if ($self->is_type_all (qw/SOURCE/)) {
    # Source file
    # --------------------------------------------------------------------------
    # Determine whether the language of the source file is supported
    my %tool_src = %{ $self->setting ('TOOL_SRC') };

    return () unless $self->lang;

    # Compile object
    # --------------------------------------------------------------------------
    if ($self->objbase) {
      # Depends on the source file
      my @dep = ($self->rule_src);

      # Depends on the compiler flags flags-file
      my @flags;
      push @flags, ('FLAGS' )
        if $self->flagsbase ('FLAGS' );
      push @flags, ('PPKEYS')
        if $self->flagsbase ('PPKEYS') and not $self->ppsrc;

      push @dep, $self->flagsbase ($_) for (@flags);

      # Source file dependencies
      for my $name (sort keys %{ $self->dep }) {
        # A Fortran 9X module, lower case object file name
        if ($self->dep ($name) eq 'USE') {
          (my $root = $name) =~ s/\.\w+$//;
          push @dep, lc ($root) . $outfile_ext{OBJ};

        # An include file
        } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
          push @dep, $name;
        }
      }

      $rules->{$self->objbase} = {ACTION => 'COMPILE', DEP => \@dep};

      # Touch flags-files
      # ------------------------------------------------------------------------
      for my $flag (@flags) {
        next unless $self->flagsbase ($flag);

        $rules->{$self->flagsbase ($flag)} = {
          ACTION => 'TOUCH',
          DEP    => [
            $self->flagsbase ($tool_src{$self->lang}{$flag}, -2),
          ],
          DEST   => '$(FCM_FLAGSDIR)',
        };
      }
    }

    if ($self->exebase) {
      # Link into an executable
      # ------------------------------------------------------------------------
      my @dep = ();
      push @dep, $self->objbase               if $self->objbase;
      push @dep, $self->flagsbase ('LD'     ) if $self->flagsbase ('LD'     );
      push @dep, $self->flagsbase ('LDFLAGS') if $self->flagsbase ('LDFLAGS');

      # Depends on BLOCKDATA program units, for Fortran programs
      my %blockdata = %{ $self->setting ('BLD_BLOCKDATA') };
      my @blkobj    = ();

      if ($self->is_type_any (qw/FPP FORTRAN/) and keys %blockdata) {
        # List of BLOCKDATA object files
        if (exists $blockdata{$self->exebase}) {
          @blkobj = split /\s+/, $blockdata{$self->exebase};

        } elsif (exists $blockdata{''}) {
          @blkobj = split /\s+/, $blockdata{''};
        }

        for my $name (@blkobj) {
          (my $root = $name) =~ s/\.\w+$//;
          $name = $root . $outfile_ext{OBJ};
          push @dep, $root . $outfile_ext{DONE};
        }
      }

      # Extra executable dependencies
      my %exe_dep = %{ $self->setting ('BLD_DEP_EXE') };
      if (keys %exe_dep) {
        my @exe_deps;
        if (exists $exe_dep{$self->exebase}) {
          @exe_deps = split /\s+/, $exe_dep{$self->exebase};

        } elsif (exists $exe_dep{''}) {
          @exe_deps = $exe_dep{''} ? split (/\s+/, $exe_dep{''}) : ('');
        }

        my $pattern = '\\' . $outfile_ext{OBJ} . '$';

        for my $name (@exe_deps) {
          if ($name =~ /$pattern/) {
            # Extra dependency is an object
            (my $root = $name) =~ s/\.\w+$//;
            push @dep, $root . $outfile_ext{DONE};

          } else {
            # Extra dependency is a sub-package
            my $var;
            if ($self->setting ('FCM_PCK_OBJECTS', $name)) {
              # sub-package name contains unusual characters
              $var = $self->setting ('FCM_PCK_OBJECTS', $name);

            } else {
              # sub-package name contains normal characters
              $var = $name ? join ('__', ('OBJECTS', $name)) : 'OBJECTS';
            }

            push @dep, '$(' . $var . ')';
          }
        }
      }

      # Source file dependencies
      for my $name (sort keys %{ $self->dep }) {
        (my $root = $name) =~ s/\.\w+$//;

        # Lowercase name for object dependency
        $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;

        # Select "done" file extension
        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
          push @dep, $name . $outfile_ext{IDONE};

        } else {
          push @dep, $root . $outfile_ext{DONE};
        }
      }

      $rules->{$self->exebase} = {
        ACTION => 'LOAD', DEP => \@dep, BLOCKDATA => \@blkobj,
      };

      # Touch Linker flags-file
      # ------------------------------------------------------------------------
      for my $flag (qw/LD LDFLAGS/) {
        $rules->{$self->flagsbase ($flag)} = {
          ACTION => 'TOUCH',
          DEP    => [$self->flagsbase ($flag, -2)],
          DEST   => '$(FCM_FLAGSDIR)',
        };
      }

    }

    if ($self->donebase) {
      # Touch done file
      # ------------------------------------------------------------------------
      my @dep = ($self->objbase);

      for my $name (sort keys %{ $self->dep }) {
        (my $root = $name) =~ s/\.\w+$//;

        # Lowercase name for object dependency
        $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;

        # Select "done" file extension
        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
          push @dep, $name . $outfile_ext{IDONE};

        } else {
          push @dep, $root . $outfile_ext{DONE};
        }
      }

      $rules->{$self->donebase} = {
        ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
      };
    }
    
    if ($self->interfacebase) {
      # Interface target
      # ------------------------------------------------------------------------
      # Source file dependencies
      my @dep = ();
      for my $name (sort keys %{ $self->dep }) {
        # Depends on Fortran 9X modules
        push @dep, lc ($name) . $outfile_ext{OBJ}
          if $self->dep ($name) eq 'USE';
      }

      $rules->{$self->interfacebase} = {ACTION => '', DEP => \@dep};
    }

  } elsif ($self->is_type_all ('INCLUDE')) {
    # Copy include target
    # --------------------------------------------------------------------------
    my @dep = ($self->rule_src);

    for my $name (sort keys %{ $self->dep }) {
      # A Fortran 9X module, lower case object file name
      if ($self->dep ($name) eq 'USE') {
        (my $root = $name) =~ s/\.\w+$//;
        push @dep, lc ($root) . $outfile_ext{OBJ};

      # An include file
      } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
        push @dep, $name;
      }
    }

    $rules->{$self->curbase} = {
      ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_INCDIR)',
    };

    # Touch IDONE file
    # --------------------------------------------------------------------------
    if ($self->donebase) {
      my @dep = ($self->rule_src);

      for my $name (sort keys %{ $self->dep }) {
        (my $root = $name) =~ s/\.\w+$//;

        # Lowercase name for object dependency
        $root   = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;

        # Select "done" file extension
        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
          push @dep, $name . $outfile_ext{IDONE};

        } else {
          push @dep, $root . $outfile_ext{DONE};
        }
      }

      $rules->{$self->donebase} = {
        ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
      };
    }

  } elsif ($self->is_type_any (qw/EXE SCRIPT/)) {
    # Copy executable file
    # --------------------------------------------------------------------------
    my @dep = ($self->rule_src);

    # Depends on dummy copy file, if file is an "always build type"
    push @dep, $self->setting (qw/BLD_CPDUMMY/)
      if $self->is_type_any (split (
        /$Fcm::Config::DELIMITER_LIST/, $self->setting ('BLD_TYPE_ALWAYS_BUILD')
      ));

    # Depends on other executable files
    for my $name (sort keys %{ $self->dep }) {
      push @dep, $name if $self->dep ($name) eq 'EXE';
    }

    $rules->{$self->curbase} = {
      ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_BINDIR)',
    };

  } elsif (@{ $self->children }) {
    # Targets for top level and package flags files and dummy dependencies
    # --------------------------------------------------------------------------
    my %tool_src   = %{ $self->setting ('TOOL_SRC') };
    my %flags_tool = (LD => '', LDFLAGS => '');

    for my $key (keys %tool_src) {
      $flags_tool{$tool_src{$key}{FLAGS}} = $tool_src{$key}{COMMAND}
        if exists $tool_src{$key}{FLAGS};

      $flags_tool{$tool_src{$key}{PPKEYS}} = ''
        if exists $tool_src{$key}{PPKEYS};
    }

    for my $name (sort keys %flags_tool) {
      my @dep = $self->pkgname eq '' ? () : $self->flagsbase ($name, -2);
      push @dep, $self->flagsbase ($flags_tool{$name})
        if $self->pkgname eq '' and $flags_tool{$name};

      $rules->{$self->flagsbase ($flags_tool{$name})} = {
        ACTION => 'TOUCH',
        DEST   => '$(FCM_FLAGSDIR)',
      } if $self->pkgname eq '' and $flags_tool{$name};

      $rules->{$self->flagsbase ($name)} = {
        ACTION => 'TOUCH',
        DEP    => \@dep,
        DEST   => '$(FCM_FLAGSDIR)',
      };
    }

    # Package object and library
    # --------------------------------------------------------------------------
    {
      my @dep;
      # Add objects from children
      for my $child (sort {$a->pkgname cmp $b->pkgname} @{ $self->children }) {
        push @dep, $child->rule_obj_var (1)
          if $child->libbase and $child->rules ($child->libbase);
        push @dep, $child->objbase
          if $child->cursrc and $child->objbase and
             not $child->is_type_any (qw/PROGRAM BLOCKDATA/);
      }

      if (@dep) {
        $rules->{$self->libbase} = {ACTION => 'AR', DEP => \@dep};
      }
    }

    # Package data files
    # --------------------------------------------------------------------------
    {
      my @dep;
      for my $child (@{ $self->children }) {
        push @dep, $child->rule_src if $child->src and not $child->type;
      }

      if (@dep) {
        push @dep, $self->setting (qw/BLD_CPDUMMY/);
        $rules->{$self->etcbase} = {
          ACTION => 'CP_DATA', DEP => \@dep, DEST => '$(FCM_ETCDIR)',
        };
      }
    }
  }

  return $rules;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->get_setting ($setting[, @prefix]);
#
# DESCRIPTION
#   This method gets the correct $setting for the current source by following
#   its package name. If @prefix is set, get the setting with the given prefix.
# ------------------------------------------------------------------------------

sub get_setting {
  my ($self, $setting, @prefix) = @_;

  my $val;
  for my $name (reverse @{ $self->pkgnames }) {
    my @names = split /__/, $name;
    $val = $self->setting ($setting, join ('__', (@prefix, @names)));

    $val = $self->setting ($setting, join ('__', (@prefix, @names)))
      if (not defined $val) and @names and $names[-1] =~ s/\.[^\.]+$//;
    last if defined $val;
  }

  return $val;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $type = $self->get_type();
#
# DESCRIPTION
#   This method determines whether the source is a type known to the
#   build system. If so, it returns the type flags delimited by "::".
# ------------------------------------------------------------------------------

sub get_type {
  my $self = shift();
  my @IGNORE_LIST
    = split(/$Fcm::Config::DELIMITER_LIST/, $self->setting('INFILE_IGNORE'));
  if (grep {$self->curbase() eq $_} @IGNORE_LIST) {
    return q{};
  }
  # User defined
  my $type = $self->setting('BLD_TYPE', $self->pkgname());
  # Extension
  if (!defined($type)) {
    my $ext = $self->curext() ? substr($self->curext(), 1) : q{};
    $type = $self->setting('INFILE_EXT', $ext);
  }
  # Pattern of name
  if (!defined($type)) {
    my %NAME_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_PAT')};
    PATTERN:
    while (my ($pattern, $value) = each(%NAME_PATTERN_TO_TYPE_HASH)) {
      if ($self->curbase() =~ $pattern) {
        $type = $value;
        last PATTERN;
      }
    }
  }
  # Pattern of #! line
  if (!defined($type) && -s $self->cursrc() && -T _) {
    my $handle = _open($self->cursrc());
    my $line = readline($handle);
    close($handle);
    my %SHEBANG_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_TXT')};
    PATTERN:
    while (my ($pattern, $value) = each(%SHEBANG_PATTERN_TO_TYPE_HASH)) {
      if ($line =~ qr{^\#!.*$pattern}msx) {
        $type = $value;
        last PATTERN;
      }
    }
  }
  if (!$type) {
    return $type;
  }
  # Extra type information for selected file types
  my %EXTRA_FOR = (
    qr{\b (?:FORTRAN|FPP) \b}msx => \&_get_type_extra_for_fortran,
    qr{\b C \b}msx               => \&_get_type_extra_for_c,
  );
  EXTRA:
  while (my ($key, $code_ref) = each(%EXTRA_FOR)) {
    if ($type =~ $key) {
      my $handle = _open($self->cursrc());
      LINE:
      while (my $line = readline($handle)) {
        my $extra = $code_ref->($line);
        if ($extra) {
          $type .= $Fcm::Config::DELIMITER . $extra;
          last LINE;
        }
      }
      close($handle);
      last EXTRA;
    }
  }
  return $type;
}

sub _get_type_extra_for_fortran {
  my ($match) = $_[0] =~ qr{\A \s* (PROGRAM|MODULE|BLOCK\s*DATA) \b}imsx;
  if (!$match) {
    return;
  }
  $match =~ s{\s}{}g;
  uc($match)
}

sub _get_type_extra_for_c {
  ($_[0] =~ qr{int\s+main\s*\(}msx) ? 'PROGRAM' : undef;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $flag = $obj->is_in_package ($name);
#
# DESCRIPTION
#   This method returns true if current package is in the package $name.
# ------------------------------------------------------------------------------

sub is_in_package {
  my ($self, $name) = @_;
  
  my $return = 0;
  for (@{ $self->pkgnames }) {
    next unless /^$name(?:\.\w+)?$/;
    $return = 1;
    last;
  }

  return $return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $flag = $obj->is_type_all ($arg, ...);
#   $flag = $obj->is_type_any ($arg, ...);
#
# DESCRIPTION
#   This method returns a flag for the following:
#     is_type_all - does type match all of the arguments?
#     is_type_any - does type match any of the arguments?
# ------------------------------------------------------------------------------

for my $name ('all', 'any') {
  no strict 'refs';

  my $subname = 'is_type_' . $name;

  *$subname = sub {
    my ($self, @intypes) = @_;

    my $rc = 0;
    if ($self->type) {
      my %types = map {($_, 1)} split /$Fcm::Config::DELIMITER/, $self->type;

      for my $intype (@intypes) {
        $rc = exists $types{$intype};
        last if ($name eq 'all' and not $rc) or ($name eq 'any' and $rc);
      }
    }

    return $rc;
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $obj->rule_obj_var ([$read]);
#
# DESCRIPTION
#   This method returns a string containing the make rule object variable for
#   the current package. If $read is set, return $($string)
# ------------------------------------------------------------------------------

sub rule_obj_var {
  my ($self, $read) = @_;

  my $return;
  if ($self->setting ('FCM_PCK_OBJECTS', $self->pkgname)) {
    # Package name registered in unusual list
    $return = $self->setting ('FCM_PCK_OBJECTS', $self->pkgname);

  } else {
    # Package name not registered in unusual list
    $return = $self->pkgname
              ? join ('__', ('OBJECTS', $self->pkgname)) : 'OBJECTS';
  }

  $return = $read ? '$(' . $return . ')' : $return;

  return $return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $obj->rule_src ();
#
# DESCRIPTION
#   This method returns a string containing the location of the source file
#   relative to the build root. This string will be suitable for use in a
#   "Make" rule file for FCM.
# ------------------------------------------------------------------------------

sub rule_src {
  my $self = shift;

  my $return = $self->cursrc;
  LABEL: for my $name (qw/SRC PPSRC/) {
    for my $i (0 .. @{ $self->setting ('PATH', $name) } - 1) {
      my $dir = $self->setting ('PATH', $name)->[$i];
      next unless index ($self->cursrc, $dir) == 0;

      $return = File::Spec->catfile (
        '$(FCM_' . $name . 'DIR' . ($i ? $i : '') . ')',
        File::Spec->abs2rel ($self->cursrc, $dir),
      );
      last LABEL;
    }
  }

  return $return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = $obj->write_lib_dep_excl ();
#
# DESCRIPTION
#   This method writes a set of exclude dependency configurations for the
#   library of this package.
# ------------------------------------------------------------------------------

sub write_lib_dep_excl {
  my $self = shift();
  if (!find_file_in_path($self->libbase(), $self->setting(qw/PATH LIB/))) {
    return 0;
  }

  my $ETC_DIR = $self->setting(qw/PATH ETC/)->[0];
  my $CFG_EXT = $self->setting(qw/OUTFILE_EXT CFG/);
  my $LABEL_OF_EXCL_DEP = $self->cfglabel('BLD_DEP_EXCL');
  my @SETTINGS = (
       #dependency   #source file type list       #dependency name function
       ['H'        , [qw{INCLUDE CPP          }], sub {$_[0]->base()}         ],
       ['INTERFACE', [qw{INCLUDE INTERFACE    }], sub {$_[0]->base()}         ],
       ['INC'      , [qw{INCLUDE              }], sub {$_[0]->base()}         ],
       ['USE'      , [qw{SOURCE FORTRAN MODULE}], sub {$_[0]->root()}         ],
       ['INTERFACE', [qw{SOURCE FORTRAN       }], sub {$_[0]->interfacebase()}],
       ['OBJ'      , [qw{SOURCE               }], sub {$_[0]->root()}         ],
  );

  my $cfg = Fcm::CfgFile->new();
  my @stack = ($self);
  NODE:
  while (my $node = pop(@stack)) {
    # Is a directory
    if (@{$node->children()}) {
      push(@stack, reverse(@{$node->children()}));
      next NODE;
    }
    # Is a typed file
    if (
          $node->cursrc()
      &&  $node->type()
      &&  !$node->is_type_any(qw{PROGRAM BLOCKDATA})
    ) {
      for (@SETTINGS) {
        my ($key, $type_list_ref, $name_func_ref) = @{$_};
        my $name = $name_func_ref->($node);
        if ($name && $node->is_type_all(@{$type_list_ref})) {
          push(
            @{$cfg->lines()},
            Fcm::CfgLine->new(
              label => $LABEL_OF_EXCL_DEP,
              value => $key . $Fcm::Config::DELIMITER . $name,
            ),
          );
          next NODE;
        }
      }
    }
  }

  # Write to configuration file
  $cfg->print_cfg(
    File::Spec->catfile($ETC_DIR, $self->libbase('lib', $CFG_EXT)),
  );
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $obj->write_rules ();
#
# DESCRIPTION
#   This method returns a string containing the "Make" rules for building the
#   source file.
# ------------------------------------------------------------------------------

sub write_rules {
  my $self  = shift;
  my $mk    = '';

  for my $target (sort keys %{ $self->rules }) {
    my $rule = $self->rules ($target);
    next unless defined ($rule->{ACTION});

    if ($rule->{ACTION} eq 'AR') {
      my $var = $self->rule_obj_var;
      $mk .= ($var eq 'OBJECTS' ? 'export ' : '') . $var . ' =';
      $mk .= ' ' . join (' ', @{ $rule->{DEP} });
      $mk .= "\n\n";
    }

    $mk .= $target . ':';
    
    if ($rule->{ACTION} eq 'AR') {
      $mk .= ' ' . $self->rule_obj_var (1);

    } else {
      for my $dep (@{ $rule->{DEP} }) {
        $mk .= ' ' . $dep;
      }
    }

    $mk .= "\n";

    if (exists $rule->{ACTION}) {
      if ($rule->{ACTION} eq 'AR') {
        $mk .= "\t" . 'fcm_internal archive $@ $^' . "\n";

      } elsif ($rule->{ACTION} eq 'CP') {
        $mk .= "\t" . 'cp $< ' . $rule->{DEST} . "\n";
        $mk .= "\t" . 'chmod u+w ' .
               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";

      } elsif ($rule->{ACTION} eq 'CP_DATA') {
        $mk .= "\t" . 'cp $^ ' . $rule->{DEST} . "\n";
        $mk .= "\t" . 'touch ' .
               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";

      } elsif ($rule->{ACTION} eq 'COMPILE') {
        if ($self->lang) {
          $mk .= "\t" . 'fcm_internal compile:' . substr ($self->lang, 0, 1) .
                 ' ' . $self->pkgnames->[-2] . ' $< $@';
          $mk .= ' 1' if ($self->flagsbase ('PPKEYS') and not $self->ppsrc);
          $mk .= "\n";
        }

      } elsif ($rule->{ACTION} eq 'LOAD') {
        if ($self->lang) {
          $mk .= "\t" . 'fcm_internal load:' . substr ($self->lang, 0, 1) .
                 ' ' . $self->pkgnames->[-2] . ' $< $@';
          $mk .= ' ' . join (' ', @{ $rule->{BLOCKDATA} })
            if @{ $rule->{BLOCKDATA} };
          $mk .= "\n";
        }

      } elsif ($rule->{ACTION} eq 'TOUCH') {
        $mk .= "\t" . 'touch ' .
               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
      }
    }

    $mk .= "\n";
  }

  return $mk;
}

# Wraps "chdir". Returns old directory.
sub _chdir {
  my ($self, $dir) = @_;
  my $old_cwd = cwd();
  $self->_event('CHDIR', $dir);
  chdir($dir) || croak(sprintf($ERR_MESS_OF{CHDIR}, $dir));
  $old_cwd;
}

# Wraps an event.
sub _event {
  my ($self, $key, @args) = @_;
  my ($format, $level) = @{$EVENT_SETTING_OF{$key}};
  $level ||= 1;
  if ($self->verbose() >= $level) {
    printf($format . ".\n", @args);
  }
}

# Wraps "open".
sub _open {
  my ($path, $mode) = @_;
  $mode ||= '<';
  open(my $handle, $mode, $path) || croak(sprintf($ERR_MESS_OF{OPEN}, $path, $!));
  $handle;
}

# ------------------------------------------------------------------------------

1;

__END__