#!/usr/bin/perl
# ------------------------------------------------------------------------------
# NAME
#   Fcm::SrcFile
#
# DESCRIPTION
#   This class contains methods to manipulate the build process of a source
#   file of supported type.
#
# 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.
# ------------------------------------------------------------------------------

package Fcm::SrcFile;

# Standard pragma

use strict;
use warnings;

# Standard modules
use Cwd;
use Carp;
use File::Basename;
use File::Spec;
use File::Spec::Functions;

# FCM component modules
use Fcm::Util;
use Fcm::Timer;

# Other modules
use Ecmwf::Fortran90_stuff ();

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $srcfile = Fcm::SrcFile->new (
#     CONFIG     => $config,
#     SRCPACKAGE => $srcpackage,
#     SRC        => $src,
#     PPSRC      => $ppsrc,
#     TYPE       => $type,
#     SCAN       => $scan,
#     TARGET     => $target,
#     PCKCFG     => $pckcfg,
#   );
#
# DESCRIPTION
#   This method constructs a new instance of the Fcm::Extract class.
#
# ARGUMENTS
#   CONFIG     - reference to a Fcm::Config instance
#   SRCPACKAGE - reference to the container Fcm::SrcPackage instance
#   SRC        - source path of this file
#   PPSRC      - pre-processed source path of this file
#   TYPE       - type flag of this source file
#   SCAN       - scan source file for dependency?
#   TARGET     - name of executable or library target
#   PCKCFG     - this source file is modified by a package cfg?
# ------------------------------------------------------------------------------

sub new {
  my $this  = shift;
  my %args  = @_;
  my $class = ref $this || $this;

  my $self = {
    CONFIG     => exists $args{CONFIG}     ? $args{CONFIG}     : &main::cfg,
    SRCPACKAGE => exists $args{SRCPACKAGE} ? $args{SRCPACKAGE} : undef,
    SRC        => exists $args{SRC}        ? $args{SRC}        : undef,
    PPSRC      => exists $args{PPSRC}      ? $args{PPSRC}      : undef,
    TYPE       => exists $args{TYPE}       ? $args{TYPE}       : undef,
    SCAN       => exists $args{SCAN}       ? $args{SCAN}       : 1,
    TARGET     => exists $args{TARGET}     ? $args{TARGET}     : undef,
    PCKCFG     => exists $args{PCKCFG}     ? $args{PCKCFG}     : undef,

    INTNAME    => undef,
    DEP        => {}, 
  };
  bless $self, $class;

  return $self;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $config = $srcfile->config;
#
# DESCRIPTION
#   This method returns a reference to the Fcm::Config instance.
# ------------------------------------------------------------------------------

sub config {
  my $self = shift;

  return $self->{CONFIG};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $srcpackage = $srcfile->srcpackage;
#   $srcfile->srcpackage ($srcpackage);
#
# DESCRIPTION
#   This method returns the reference to the container Fcm::SrcPackage of this
#   source file. If an argument is specified, the reference is set to the
#   value of the argument.
# ------------------------------------------------------------------------------

sub srcpackage {
  my $self = shift;

  if (@_) {
    $self->{SRCPACKAGE} = shift;
  }

  return $self->{SRCPACKAGE};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $src = $srcfile->src;
#   $srcfile->src ($src);
#
# DESCRIPTION
#   This method returns the reference to the location of this source file. If
#   an argument is specified, the location is set to the value of the argument.
# ------------------------------------------------------------------------------

sub src {
  my $self = shift;

  if (@_) {
    $self->{SRC} = shift;
  }

  return $self->{SRC};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $ppsrc = $srcfile->ppsrc;
#   $srcfile->ppsrc ($ppsrc);
#
# DESCRIPTION
#   This method returns the reference to the location of the pre-processed
#   file of this source file. If an argument is specified, the location is set
#   to the value of the argument.
# ------------------------------------------------------------------------------

sub ppsrc {
  my $self = shift;

  if (@_) {
    $self->{PPSRC} = shift;
  }

  return $self->{PPSRC};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $time = $srcfile->mtime;
#
# DESCRIPTION
#   This method returns the last modified time of the source file. If a
#   pre-processed version of the source file exists, it returns the last
#   modified time of the pre-processed source file instead.
# ------------------------------------------------------------------------------

sub mtime {
  my $self = shift;

  return $self->{PPSRC} ? (stat $self->{PPSRC})[9] : (stat $self->{SRC})[9];
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $base = $srcfile->base;
#
# DESCRIPTION
#   This method returns the base name of the source file.
# ------------------------------------------------------------------------------

sub base {
  my $self = shift;

  return basename ($self->{SRC});
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $ppbase = $srcfile->ppbase;
#
# DESCRIPTION
#   This method returns the base name of the pre-processed source file.
# ------------------------------------------------------------------------------

sub ppbase {
  my $self = shift;

  return basename ($self->{PPSRC});
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $interfacebase = $srcfile->interfacebase;
#
# DESCRIPTION
#   This method returns the base name of the F9X interface file.
# ------------------------------------------------------------------------------

sub interfacebase {
  my $self = shift;

  my $flag = lc ($self->select_tool ('INTERFACE'));
  my $ext  = $self->config->setting (qw/OUTFILE_EXT INTERFACE/);

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

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $root = $srcfile->root;
#
# DESCRIPTION
#   This method returns the root name (i.e. base name without file extension)
#   of the source file.
# ------------------------------------------------------------------------------

sub root {
  my $self = shift;

  (my $root = $self->base) =~ s/\.\w+$//;

  return $root;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $ext = $srcfile->ext;
#
# DESCRIPTION
#   This method returns the file extension of the source file.
# ------------------------------------------------------------------------------

sub ext {
  my $self = shift;

  return substr $self->base, length ($self->root);
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $ppext = $srcfile->ppext;
#
# DESCRIPTION
#   This method returns the file extension of the pre-processed source file.
# ------------------------------------------------------------------------------

sub ppext {
  my $self = shift;

  return substr $self->ppbase, length ($self->root);
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $dir = $srcfile->dir;
#
# DESCRIPTION
#   This method returns the dir name of the source file.
# ------------------------------------------------------------------------------

sub dir {
  my $self = shift;

  return dirname ($self->{SRC});
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $ppdir = $srcfile->ppdir;
#
# DESCRIPTION
#   This method returns the dir name of the pre-processed source file.
# ------------------------------------------------------------------------------

sub ppdir {
  my $self = shift;

  return dirname ($self->{PPSRC});
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $type = $srcfile->type;
#   $srcfile->type ($type);
#
# DESCRIPTION
#   This method returns the type flag of the source file. If an argument is
#   specified, the flag is set to the value of the argument.
# ------------------------------------------------------------------------------

sub type {
  my $self = shift;

  if (@_) {
    $self->{TYPE} = shift;
  }

  return $self->{TYPE};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $flag = $srcfile->is_type ($type1[, $type2, ...]);
#
# DESCRIPTION
#   This method returns true if current file is a known type matching all the
#   arguments.
# ------------------------------------------------------------------------------

sub is_type {
  my $self    = shift;
  my @intypes = @_;
  my $rc      = 0;

  if ($self->{TYPE}) {
    my @types = split /::/, $self->{TYPE};

    for my $intype (@intypes) {
      $rc = grep {uc $_ eq uc $intype} @types;
      last unless $rc;
    }

  }

  return $rc;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $flag = $srcfile->is_type_or ($type1[, $type2, ...]);
#
# DESCRIPTION
#   This method returns true if current file is a known type matching any of
#   the arguments.
# ------------------------------------------------------------------------------

sub is_type_or {
  my $self    = shift;
  my @intypes = @_;
  my $rc      = 0;

  if ($self->{TYPE}) {
    my @types = split /::/, $self->{TYPE};

    for my $intype (@intypes) {
      $rc = grep {uc $_ eq uc $intype} @types;
      last if $rc;
    }

  }

  return $rc;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $flag = $srcfile->scan ();
#   $srcfile->scan ($flag);
#
# DESCRIPTION
#   This method returns the "scan" flag that determines whether the source
#   file needs to be scanned for dependency. If an argument is specified, the
#   flag is set to the value of the argument.
# ------------------------------------------------------------------------------

sub scan {
  my $self = shift;

  if (@_) {
    $self->{SCAN} = $_[0];
  }

  return $self->{SCAN};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $target = $srcfile->target ();
#   $srcfile->target ($target);
#
# DESCRIPTION
#   This method returns the name of the build target of the source file. (This
#   affects only the executable names of main programs and file names of
#   binary object libraries.) If an argument is specified, the target is set to
#   the value of the argument.
# ------------------------------------------------------------------------------

sub target {
  my $self = shift;

  if (@_) {
    $self->{TARGET} = $_[0];
  }

  my $return;

  if ($self->config->setting ('EXE_NAME', $self->root)) {
    $return = $self->config->setting ('EXE_NAME', $self->root);

  } elsif ($self->{TARGET}) {
    $return = $self->{TARGET};

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

  return $return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $pckcfg = $srcfile->pckcfg ();
#   $srcfile->pckcfg ($pckcfg);
#
# DESCRIPTION
#   This method returns the name of the flag to indicate whether this source
#   file is modified by a package level configuration file. If an argument is
#   specified, the flag is set to the value of the argument.
# ------------------------------------------------------------------------------

sub pckcfg {
  my $self = shift;

  if (@_) {
    $self->{PCKCFG} = $_[0];
  }

  return $self->{PCKCFG};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $progname = $srcfile->progname();
#   $srcfile->progname ($progname);
#
# DESCRIPTION
#   This method returns the name of the first program unit in a Fortran source
#   file. If an argument is specified, the name is set to the value of the
#   argument.
# ------------------------------------------------------------------------------

sub progname {
  my $self = shift;

  if (@_) {
    $self->{INTNAME} = $_[0];
  }

  return $self->{INTNAME};
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $intname = $srcfile->intname ();
#
# DESCRIPTION
#   This method returns the internal name of the source file.
# ------------------------------------------------------------------------------

sub intname {
  my $self = shift;

  return $self->{INTNAME} ? $self->{INTNAME} : lc ($self->root);
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   %dep   = $srcfile->dep;
#   @files = $srcfile->dep ($type);
#   $srcfile->dep (\%dep);
#
# DESCRIPTION
#   This method returns the dependencies of this source file. If no argument
#   is set, the method returns the dependency hash of this source file. The
#   keys of the hash are the names of the files this source files depends on
#   and the values of the hash are the dependency types of the corresponding
#   files. If an argument is specified and the argument is a normal string,
#   the method returns the keys of the dependency hash, which have their
#   corresponding values equal to $type. If an argument is specified and the
#   argument is a reference to a hash, the reference to the dependency hash of
#   the current source file is re-set to point to the reference of this new
#   hash.
# ------------------------------------------------------------------------------

sub dep {
  my $self = shift;

  if (@_) {
    if (ref $_[0] eq 'HASH') {
      $self->{DEP} = $_[0];

    } else {
      my $type = $_[0];
      return grep {
        $self->{DEP}{$_} eq $type;
      } keys %{ $self->{DEP} };
    }
  }

  return %{ $self->{DEP} };
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $srcfile->add_dep ($target, $type);
#
# DESCRIPTION
#   This method adds (or modifies) a dependency to the dependency hash of the
#   source file. The argument $type is the type of the dependency and the
#   argument $target is the dependency target.
# ------------------------------------------------------------------------------

sub add_dep {
  my $self = shift;
  my ($target, $type) = @_;

  $self->{DEP}{$target} = $type;

  return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   @pklist = $self->get_package_list ();
#
# DESCRIPTION
#   This method returns a list of package names associated with this source
#   file. The list begins with the top level container package to the
#   sub-package name of the current source file.
# ------------------------------------------------------------------------------

sub get_package_list {
  my $self = shift;

  my @pknames = ();

  my @packages = split /__/, $self->srcpackage->name;
  push @packages, $self->root;

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

  return @pknames;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $srcfile->determine_type;
#
# DESCRIPTION
#   This method determines whether the source file is a type known to the
#   build system. If so, it sets the "type" flag.
# ------------------------------------------------------------------------------

sub determine_type {
  my $self = shift;

  if (not $self->{TYPE}) {
    # Determine file type by comparing its extension with supported ones
    my %known_ext = %{ $self->config->setting ('INFILE_EXT') };
    my $ext       = $self->ext ? substr ($self->ext, 1) : 0;
    $self->{TYPE} = $known_ext{$ext} if $ext and exists $known_ext{$ext};
  }

  if (not $self->{TYPE}) {
    # Determine file type by comparing its name with known patterns
    my %known_pat = %{ $self->config->setting ('INFILE_PAT') };
    for my $pat (keys %known_pat) {
      if ($self->base =~ /$pat/) {
        $self->{TYPE} = $known_pat{$pat};
        last;
      }
    }
  }

  if (-s $self->{SRC} and -T $self->{SRC} and not $self->{TYPE}) {
    # Determine file type by inspecting its first line (text file only)
    if (open SRC, '<', $self->{SRC}) {
      my $line = <SRC>;
      close SRC;

      my %known_txt = %{ $self->config->setting ('INFILE_TXT') };
      for my $txt (keys %known_txt) {
        if ($line =~ /^#!.*$txt/) {
          $self->{TYPE} = $known_txt{$txt};
          last;
        }
      }
    }
  }

  if ($self->is_type_or (qw/FORTRAN FPP/)) {
    # Determine whether source file is a main Fortran program or module
    if (open SRC, '<', $self->{SRC}) {
      while (my $line = <SRC>) {
        if ($line =~ /^\s*(PROGRAM|MODULE)\b/i) {
          $self->{TYPE} = $self->{TYPE} . '::' . uc ($1);
          last;

        } elsif ($line =~ /^\s*BLOCK\s*DATA\b/i) {
          $self->{TYPE} = $self->{TYPE} . '::' . 'BLOCKDATA';
          last;
        }
      }
      close SRC;
    }

  } elsif ($self->is_type (qw/C/)) {
    # Determine whether source file is a main C program
    if (open SRC, '<', $self->{SRC}) {
      while (my $line = <SRC>) {
        next unless $line =~ /int\s*main\s*\(/i;
        $self->{TYPE} = $self->{TYPE} . '::PROGRAM';
        last;
      }
      close SRC;
    }
  }

  return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   @pp_src = @{ $srcfile->pre_process () };
#
# DESCRIPTION
#   This method invokes the pre-processor on the source file. It returns a
#   reference to an array containing the lines of the pre-processed source if
#   the pre-processor command succeeded.
# ------------------------------------------------------------------------------

sub pre_process {
  my $self = shift;

  # Support only Fortran and C source files
  return unless $self->is_type_or (qw/FPP C/);

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

  # Build the pre-processor command according to file type
  my $name    = $self->is_type ('FPP') ? 'FPP' : 'CPP';
  my %tool    = %{ $self->config->setting ('TOOL') };

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

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

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

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

  my $verbose = $self->config->verbose;
  my $cwd     = cwd;

  # Change to container directory of source file
  print 'cd ', $self->dir, "\n" if $verbose > 1;
  chdir $self->dir;

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

  # Change back to original directory
  print 'cd ', $cwd, "\n" if $self->config->verbose > 1;
  chdir $cwd;

  return \@outlines;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   @interface_block = @{ $srcfile->gen_interface () };
#
# DESCRIPTION
#   This method invokes the Fortran 9x 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 gen_interface {
  my $self = shift;

  my $generator = $self->select_tool ('GENINTERFACE');

  my $src      = $self->{PPSRC} ? $self->{PPSRC} : $self->{SRC};
  my @outlines = ();

  if ($generator eq 'f90aib') {
    # Use F90AIB

    # Open pipeline to interface file generator and read its output
    my $devnull = File::Spec->devnull;
    my $command = $generator;
    $command   .= " <'" . $src . "'" . " 2>'" . $devnull . "'";
    my $croak   = $command . ' failed';

    print timestamp_command ($command, 'Start') if $self->config->verbose > 2;
    open COMMAND, '-|', $command or croak $croak, ' (', $!, '), abort';
    @outlines = readline 'COMMAND';
    close COMMAND or croak $croak, ' (', $?, '), abort';
    print timestamp_command ($command, 'End  ') if $self->config->verbose > 2;

  } elsif ($generator eq 'ECMWF') {
    # Use ECMWF interface generator
  
    # Read source file into an array
    open FILE, '<', $src or croak 'Cannot open "', $src, '" (', $!, '), abort';
    my @src_lines = <FILE>;
    close FILE;
  
    # Process standalone subroutines and functions only
    if (not grep /^\s*(?:program|module)\b/i, @src_lines) {
      print timestamp_command ('Analyse: ' . $self->src, 'Start')
        if $self->config->verbose > 2;

      my @statements = ();
      my %prog_info  = ();
  
      # Set name of source file
      &Ecmwf::Fortran90_stuff::fname ($src);
  
      # Parse lines in source
      &Ecmwf::Fortran90_stuff::setup_parse ();

      # Expand continuation lines in source
      &Ecmwf::Fortran90_stuff::expcont (\@src_lines, \@statements);
  
      # Analyse statements in source
      $Ecmwf::Fortran90_stuff::study_called = 0;
      &Ecmwf::Fortran90_stuff::study (\@statements, \%prog_info);
  
      # Source code is not a module
      if (not $prog_info{is_module}) {
        my @interface_block = ();
        my @line_hash       = ();
  
        # Create an interface block for the program unit
        &Ecmwf::Fortran90_stuff::create_interface_block (
          \@statements,
          \@interface_block,
        );

        # Put continuation lines back
        &Ecmwf::Fortran90_stuff::cont_lines (
          \@interface_block,
          \@outlines,
          \@line_hash,
        );
      }

      print timestamp_command ('Analyse: ' . $self->src, 'End')
        if $self->config->verbose > 2;
    }

  } elsif (uc ($generator) eq 'NONE') {
    print $self->root, ': interface generation is switched off', "\n"
      if $self->config->verbose > 2;

  } else {
    e_report 'Error: Unknown Fortran 9x interface generator: ', $generator, '.';
  }

  return \@outlines;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $tool = $self->select_tool ($name);
#
# DESCRIPTION
#   This method selects the correct "tool" for the current source file by
#   following the name of its container package. The argument $name must be
#   the generic name of the "tool" to be selected. The method returns the
#   value of the selected tool.
# ------------------------------------------------------------------------------

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

  return undef unless $name;

  my @pknames = $self->get_package_list ();

  my %tool    = %{ $self->config->setting ('TOOL') };

  for my $pkname (reverse @pknames) {
    my $cur_name = join '__', ($name, $pkname);
    return $tool{$cur_name} if exists $tool{$cur_name};
  }

  return exists $tool{$name} ? $tool{$name} : '';
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = $srcfile->scan_dependency ();
#   $rc = $srcfile->scan_dependency (HEADER_ONLY => 1);
#
# DESCRIPTION
#   This method scans the source file for dependencies. If no argument is
#   specified, the method scans the pre-processed source file if it exists.
#   Otherwise, the original source file is scanned. If HEADER_ONLY is
#   specified, only pre-processing header dependencies are scanned from the
#   source file. (The HEADER_ONLY flag should only be specified if "ppsrc" is
#   not already specified.) This method returns the number of 1 on success.
# ------------------------------------------------------------------------------

sub scan_dependency {
  my $self = shift;
  my %args = @_;

  my $header_only = exists $args{HEADER_ONLY} ? $args{HEADER_ONLY} : 0;

  return 0 unless $self->{SCAN};
  return 0 unless $self->{TYPE};

  my $src = $self->{PPSRC} ? $self->{PPSRC} : $self->{SRC};
  return 0 unless $src;

  # Determine what dependencies are supported by this known type
  my %types = $header_only
              ? %{ $self->config->setting ('PP_DEP_TYPE') }
              : %{ $self->config->setting ('DEP_TYPE') };

  # List of excluded dependencies
  my %excl_dep = %{ $self->config->setting ('EXCL_DEP') };

  # Package list
  my @pknames = $self->get_package_list ();

  my @depends = ();
  for my $key (keys %types) {
    # Check if current file is a type of file requiring dependency scan
    next unless $self->is_type ($key);
    
    # Get list of dependency type for this file
    DEPEND: for my $depend ((split /::/, $types{$key})) {
      # Ignore a dependency type if the dependency is in the exclude list
      if (exists $excl_dep{$depend}) {
        # Global exclude
        next DEPEND if exists $excl_dep{$depend}{''};

        # Sub-package exclude
        for my $pkname (@pknames) {
          next DEPEND if exists $excl_dep{$depend}{$pkname};
        }
      }

      # Add to dependency list for current file
      push @depends, $depend;
    }
  }

  # Scan dependencies, if necessary ...
  if (@depends) {
    # Print diagnostic
    print timestamp_command ('scan dependency in file: ' . $src, 'Start')
      if $self->config->verbose > 2;

    open FILE, '<', $src or croak 'Cannot open "', $src, '" (', $!, ')';
    my @lines = readline 'FILE';
    close FILE;

    # List of dependency patterns
    my %dep_pattern = %{ $self->config->setting ('DEP_PATTERN') };

    LINE: for my $line (@lines) {
      # Ignore empty lines
      next LINE if $line =~ /^\s*$/;

      # Fortran source, also determine internal name
      if (! $header_only and ! $self->{INTNAME}) {
        if ($self->is_type ('SOURCE') and $self->is_type_or (qw/FPP FORTRAN/)) {
          my $pfx_pttn = '(?:(?:RECURSIVE|ELEMENTAL|PURE)\s+)?';
          my $spc_pttn = '(?:(?:CHARACTER|COMPLEX|DOUBLE\s*PRECISION|INTEGER|' .
                         'LOGICAL|REAL|TYPE)(?:\s*\(.+\)|\s*\*\d+\s*)??\s+)?';

          if ($line =~ /^\s*PROGRAM\s+(\w+)/i) {
            # Matches the beginning of a named main program
            $self->{INTNAME} = lc $1;
            next LINE;

          } elsif ($line =~ /^\s*MODULE\s+(\w+)/i) {
            my $keyword = $1;

            if (uc ($keyword) ne 'PROCEDURE') {
              # Matches the beginning of a module
              $self->{INTNAME} = lc $keyword;
              next LINE;
            }

          } elsif ($line =~ /^\s*BLOCK\s*DATA\s+(\w+)/i) {
            # Matches the beginning of a named block data program unit
            $self->{INTNAME} = lc $1;
            next LINE;

          } elsif ($line =~ /^\s*$pfx_pttn SUBROUTINE\s+(\w+)/ix) {
            # Matches the beginning of a subroutine
            $self->{INTNAME} = lc $1;
            next LINE;

          } elsif ($line =~ /^\s*$pfx_pttn $spc_pttn FUNCTION\s+(\w+)/ix) {
            # Matches the beginning of a function
            $self->{INTNAME} = lc $1;
            next LINE;
          }
        }
      }

      # Scan known dependencies
      for my $depend (@depends) {
        # Check if a pattern exists for the current dependency
        next unless exists $dep_pattern{$depend};

        # Attempt to match the pattern
        my $pattern = $dep_pattern{$depend};

        if ($line =~ /$pattern/i) {
          my $match = $1;

          # $match may contain multiple items delimited by space
          NAME: for my $name (split /\s+/, $match) {
            # Skip dependency if it is in the exclusion list
            my $key = uc ($depend . '::' . $name);

            if (exists $excl_dep{$key}) {
              # Exclude this dependency, in the global list
              next NAME if exists $excl_dep{$key}{''};

              # Exclude this dependency, current sub-package
              for my $pkname (@pknames) {
                next NAME if exists $excl_dep{$key}{$pkname};
              }
            }

            # Add this dependency to the list
            $self->add_dep ($name, $depend);
          }

          next LINE;
        }
      }
    }

    # Diagnostic messages
    if ($self->config->verbose > 2) {
      my $base = $self->ppsrc ? $self->ppbase : $self->base;

      print $self->srcpackage->name, ': ', $base;
      print ': scanned ', scalar (@lines), ' lines for ';
      print 'header ' if $header_only;
      print 'dependencies: ', scalar (keys %{ $self->{DEP} }), "\n";
      print timestamp_command ('scan dependency in file: ' . $src, 'End');
    }
  }

  return 1;
}

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

sub write_makerule {
  my $self = shift;

  my $mk   = '';

  {
    if ($self->is_type (qw/SOURCE/)) {
      if ($self->is_type_or (qw/FORTRAN FPP/) and not $self->progname) {
        last;
      }

      $mk .= $self->_write_makerule_compile ();
      $mk .= $self->_write_makerule_touch ('FLAGS');

      if ($self->is_type_or (qw/FPP C/) and not $self->ppsrc) {
        $mk .= $self->_write_makerule_touch ('PPKEYS');
      }

      if ($self->is_type ('PROGRAM')) {
        $mk .= $self->_write_makerule_load ();
        $mk .= $self->_write_makerule_touch ('LD');
        $mk .= $self->_write_makerule_touch ('LDFLAGS');

      } else {
        $mk .= $self->_write_makerule_touch ('DONE');
      }
      
      if ($self->is_type_or (qw/FORTRAN FPP/) and
          uc ($self->select_tool ('GENINTERFACE')) ne 'NONE' and
          not $self->is_type_or (qw/PROGRAM MODULE/)) {
        $mk .= $self->_write_makerule_interface ();
      }

    } elsif ($self->is_type ('INCLUDE')) {
      $mk .= $self->_write_makerule_cp ('INC');
      $mk .= $self->_write_makerule_touch ('IDONE');

    } elsif ($self->is_type_or (qw/EXE SCRIPT/)) {
      $mk .= $self->_write_makerule_cp ('EXE');

    } elsif ($self->is_type ('LIB')) {
      $mk .= $self->_write_makerule_ar;
    }
  }

  return $mk;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $srcfile->_write_makerule_compile ();
#
# DESCRIPTION
#   This internal method returns a string containing the "Make" rules to
#   compile the current source file.
# ------------------------------------------------------------------------------

sub _write_makerule_compile {
  my $self = shift;

  # Create a target to build an object file from the source file
  my $base = $self->intname;
  my $mk   = $base . $self->config->setting (qw/OUTFILE_EXT OBJ/);
  $mk     .= ' : ' . $self->_makerule_srcfile;

  my $nl   = " \\\n" . ' ' x 10;

  my $type = $self->is_type ('C') ? 'C' : 'F';

  # Depends on the compiler flags dummy file
  my $flag = $type . 'FLAGS';
  $mk     .= $nl . join ('__', ($flag, $self->srcpackage->name, $self->root));
  $mk     .= $self->config->setting (qw/OUTFILE_EXT FLAGS/);

  # Depends on the pre-processor keys dummy file
  if ($self->is_type_or (qw/C FPP/) and not $self->ppsrc) {
    my $pp = $type . 'PPKEYS';
    $mk   .= $nl . join ('__', ($pp, $self->srcpackage->name, $self->root));
    $mk   .= $self->config->setting (qw/OUTFILE_EXT 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+$//;
      $mk .= $nl . lc ($root) . $self->config->setting (qw/OUTFILE_EXT OBJ/);

    # An include file
    } elsif ($self->{DEP}{$name} =~ /^(?:INC|H|INTERFACE)$/) {
      $mk .= $nl . $name;
    }
  }

  # Action: invoke the compile wrapper
  $mk .= "\n";
  $mk .= "\t" . 'fcm_internal compile:' . $type . ' ';
  $mk .= $self->srcpackage->name . ' $< $@';
  $mk .= ' 1' if ($self->is_type_or (qw/C FPP/) and not $self->ppsrc);
  $mk .= "\n";
  $mk .= "\n";

  return $mk;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $srcfile->_write_makerule_load;
#
# DESCRIPTION
#   This internal method returns a string containing the "Make" rules to
#   invoke the loader (linker) on the object file of the current source file.
# ------------------------------------------------------------------------------

sub _write_makerule_load {
  my $self = shift;

  # Create a target to build an executable from the object file
  my $target = $self->target;
  my $mk     = $target . ' : ';
  my $base   = $self->intname;
  $mk       .= $base . $self->config->setting (qw/OUTFILE_EXT OBJ/);

  my $nl   = " \\\n" . ' ' x 10;

  # Depends on the loader flags
  for my $flag (qw/LD LDFLAGS/) {
    $mk   .= $nl . join ('__', ($flag, $self->srcpackage->name, $self->root));
    $mk   .= $self->config->setting (qw/OUTFILE_EXT FLAGS/);
  }

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

  if ($self->is_type_or (qw/FPP FORTRAN/) and keys %blockdata) {
    # List of BLOCKDATA object files
    if (exists $blockdata{$target}) {
      @blockdata_objs = keys (%{ $blockdata{$target} });

    } elsif (exists $blockdata{''}) {
      @blockdata_objs = keys (%{ $blockdata{''} });
    }

    for my $name (@blockdata_objs) {
      (my $root = $name) =~ s/\.\w+$//;
      $name = $root . $self->config->setting (qw/OUTFILE_EXT OBJ/);
      $mk  .= $nl . $root . $self->config->setting (qw/OUTFILE_EXT DONE/);
    }
  }

  # Extra executable dependencies
  my %exe_dep = %{ $self->config->setting ('EXE_DEP') };
  if (keys %exe_dep) {
    my @deps;
    if (exists $exe_dep{$target}) {
      @deps = keys (%{ $exe_dep{$target} });

    } elsif (exists $exe_dep{''}) {
      @deps = keys (%{ $exe_dep{''} });
    }

    my $pattern = '\\' . $self->config->setting (qw/OUTFILE_EXT OBJ/) . '$';

    for my $name (@deps) {
      if ($name =~ /$pattern/) {
        # Extra dependency is an object
        (my $root = $name) =~ s/\.\w+$//;
        $mk .= $nl . $root . $self->config->setting (qw/OUTFILE_EXT DONE/);

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

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

        $mk   .= $nl . '$(' . $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)$/) {
      $mk .= $nl . $name . $self->config->setting (qw/OUTFILE_EXT IDONE/);

    } else {
      $mk .= $nl . $root . $self->config->setting (qw/OUTFILE_EXT DONE/);
    }
  }

  # Action: invoke the load wrapper
  $mk .= "\n";
  $mk .= "\t" . 'fcm_internal load ' . $self->srcpackage->name . ' $< $@';
  $mk .= ' ' . join (' ', @blockdata_objs) if @blockdata_objs;
  $mk .= "\n\n";

  return $mk;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $srcfile->_write_makerule_interface;
#
# DESCRIPTION
#   This internal method returns a string containing the "Make" rules to
#   update the Fortran 9X interface block target of the current source file.
# ------------------------------------------------------------------------------

sub _write_makerule_interface {
  my $self = shift;

  # Create a target to build all targets that are dependencies of the interface
  # block file of the current source file
  my $mk = $self->interfacebase;
  $mk   .= ' :';

  my $nl   = " \\\n" . ' ' x 10;

  # Source file dependencies
  for my $name (sort keys %{ $self->{DEP} }) {
    # Depends on Fortran 9X modules
    $mk .= $nl . lc ($name) . $self->config->setting (qw/OUTFILE_EXT OBJ/)
      if $self->{DEP}{$name} eq 'USE';
  }

  $mk .= "\n\n";

  return $mk;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $srcfile->_write_makerule_touch ($type);
#
# DESCRIPTION
#   This internal method returns a string containing the "Make" rules for
#   updating a dummy file. The argument $type must be set to ensure correct
#   behaviour. Recognised values for $type are "IDONE", "DONE", "FLAGS",
#   "LDFLAGS" and "PPKEYS".
# ------------------------------------------------------------------------------

sub _write_makerule_touch {
  my $self = shift;
  my $type = $_[0];

  my $mk;
  my $target;
  my $dest;
  my $flag;

  # Create a target to update the dummy "done" file for the source file
  if ($type eq 'DONE') {
    my $base = $self->intname;
    $target  = $base . $self->config->setting (qw/OUTFILE_EXT DONE/);

  # Create a target to update the dummy "idone" file for the source file
  } elsif ($type eq 'IDONE') {
    $target = $self->base . $self->config->setting (qw/OUTFILE_EXT IDONE/);

  # Create a target to update the dummy "flags" file for the source file
  } else { # if $type =~ /^(?:(?:LD)?FLAGS|PPKEYS)$/
    my $prefix = $self->is_type ('C') ? 'C' : 'F';
    $flag      = (index ($type, 'LD') == 0) ? $type : $prefix . $type;
    $target    = join '__', ($flag, $self->srcpackage->name, $self->root);
    $target   .= $self->config->setting (qw/OUTFILE_EXT FLAGS/);
  }

  my $nl   = " \\\n" . ' ' x 10;

  # The "done" or "idone" file depends on the "done" and "idone" files of the
  # source file dependencies. The "done" file is also dependent on the object
  # file of the source file, whereas the "idone" file is dependent on the source
  # file itself.
  if ($type =~ /^I?DONE$/) {
    my $base = $self->intname;
    my $dep0 = $type eq 'IDONE'
               ? $self->base
               : $base . $self->config->setting (qw/OUTFILE_EXT OBJ/);
    $dest    = '$(FCM_DONEDIR)';
    $mk      = $target . ' : ' . $dep0;

    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)$/) {
        $mk .= $nl . $name . $self->config->setting (qw/OUTFILE_EXT IDONE/);

      } else {
        $mk .= $nl . $root . $self->config->setting (qw/OUTFILE_EXT DONE/);
      }
    }

  # The "flags" file for the source file depends on the "flags" file for the
  # container source package of the source file.
  } else { # if $type =~ /^(?:(?:LD)?FLAGS|PPKEYS)$/
    $dest = '$(FCM_FLAGSDIR)';
    $mk  .= $target . ' : ' . $flag . '__' . $self->srcpackage->name;
    $mk  .= $self->config->setting (qw/OUTFILE_EXT FLAGS/);
  }

  # Action: invoke the "touch" command
  $mk .= "\n";
  $mk .= "\t" . 'touch ' . catfile ($dest, '$@') . "\n";
  $mk .= "\n";

  return $mk;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $srcfile->_write_makerule_cp ($type);
#
# DESCRIPTION
#   This internal method returns a string containing the "Make" rules for
#   copying the source file to its destination. The argument $type must be set
#   to ensure correct behaviour. Recognised values for $type are "INC" and
#   "EXE".
# ------------------------------------------------------------------------------

sub _write_makerule_cp {
  my $self = shift;
  my $type = $_[0];

  # Create a target to copy the source file to a pre-defined destination
  my $mk  = $self->base . ' : ' . $self->_makerule_srcfile;
  my $dest;

  my $nl  = " \\\n" . ' ' x 10;

  # An "include" file goes to the "inc" sub-directory of the build.
  if ($type eq 'INC') {
    $dest = '$(FCM_INCDIR)';

    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+$//;
        $mk .= $nl . lc ($root) . $self->config->setting (qw/OUTFILE_EXT OBJ/);

      # An include file
      } elsif ($self->{DEP}{$name} =~ /^(?:INC|H|INTERFACE)$/) {
        $mk .= $nl . $name;
      }
    }

  # An executable file goes to the "bin" sub-directory of the build.
  } else { # if $type eq 'EXE'
    $dest = '$(FCM_BINDIR)';

    # Depends on dummy copy file, if file is an "always build type"
    $mk .= $nl . $self->config->setting (qw/MISC CPDUMMY/)
      if $self->is_type_or (
        split (/,/, $self->config->setting ('ALWAYS_BUILD_TYPE'))
      );

    # Depends on other executable files
    for my $name (sort keys %{ $self->{DEP} }) {
      $mk .= $nl . $name if $self->{DEP}{$name} eq 'EXE';
    }
  }

  # Action: copy file, and chmod to grant write permission to the user
  $mk .= "\n";
  $mk .= "\t" . 'cp $< ' . $dest . "\n";
  $mk .= "\t" . 'chmod u+w ' . catfile ($dest, '$@') . "\n";
  $mk .= "\n";

  return $mk;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $srcfile->_write_makerule_ar ();
#
# DESCRIPTION
#   This internal method returns a string containing the "Make" rules for
#   building an object library.
# ------------------------------------------------------------------------------

sub _write_makerule_ar {
  my $self = shift;

  # Create a target to build a binary object library
  my $target = $self->target;
  my $mk = $target . ' :';

  my $nl = " \\\n" . ' ' x 10;

  # Depends on its member object files
  for my $name (sort keys %{ $self->{DEP} }) {
    next unless $self->{DEP}{$name} eq 'OBJ';

    if ($name =~ /^\$\(\w+\)$/) {
      # Dependency is a Makefile variable
      $mk .= $nl . $name;

    } else {
      # Dependency is an object
      (my $root = $name) =~ s/\.\w+$//;
      $mk .= $nl . lc ($root) . $self->config->setting (qw/OUTFILE_EXT OBJ/);
    }
  }

  # Action: invoke the archiver
  $mk .= "\n";
  $mk .= "\t" . 'fcm_internal archive $@ $^' . "\n";
  $mk .= "\n";

  return $mk;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $string = $srcfile->_makerule_srcfile ();
#
# DESCRIPTION
#   This internal method returns a string containing the location of the
#   source file relative to a package source path. This string will be
#   suitable for use in a "Make" rule file for FCM.
# ------------------------------------------------------------------------------

sub _makerule_srcfile {
  my $self = shift;

  my $return;
  my @searchpath;
  my $label;
  my $dir;
  my $base;

  if ($self->ppsrc) {
    $return     = $self->ppsrc;
    @searchpath = $self->srcpackage->ppsearchpath;
    $label      = 'PPSRCDIR';
    $dir        = $self->ppdir;
    $base       = $self->ppbase;

  } else {
    $return     = $self->src;
    @searchpath = $self->srcpackage->searchpath;
    $label      = 'SRCDIR';
    $dir        = $self->dir;
    $base       = $self->base;
  }

  $return = catfile $dir, $base;

  # Use variable for directory name
  # if container package name contains word characters only
  if ($self->srcpackage->name =~ /^\w+$/) {
    for my $i (0 .. $#searchpath) {
      if ($dir eq $searchpath[$i]) {
        my $returndir = '$(' . $label . $i . '__' . $self->srcpackage->name .
                        ')';
        $return = catfile $returndir, $base;
        last;
      }
    }
  }

  return $return;
}

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

1;

__END__