#!/usr/bin/perl
# ------------------------------------------------------------------------------
# NAME
#   fcm_internal
#
# SYNOPSIS
#   fcm_internal SUBCOMMAND ARGS
#
# DESCRIPTION
#   The fcm_internal command is a frontend for some of the internal commands of
#   the FCM build system. The subcommand can be "compile", "load" or "archive"
#   for invoking the compiler, loader and library archiver respectively. If
#   "compile" is specified, it can be suffixed with ":TYPE" to specify the
#   nature of the source file. If TYPE is not specified, it is set to F by
#   default (for Fortran source). For compile and load, the other arguments are
#   the 1) name of the container package of the source file, 2) the path to the
#   source file and 3) the target name after compiling or loading the source
#   file. For compile, the 4th argument is a flag to indicate whether
#   pre-processing is required for compiling the source file. For load, the 4th
#   and the rest of the arguments is a list of object files that cannot be
#   archived into the temporary load library and must be linked into the target
#   through the linker command. (E.g. Fortran BLOCKDATA program units must be
#   linked this way.) If archive is specified, the first argument should be the
#   name of the library archive target and the rest should be the object files
#   to be included in the archive. This command is invoked via the build system
#   and should never be called directly by the user.
#
# 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.
# ------------------------------------------------------------------------------

# Standard pragmas:
use warnings;
use strict;

# FCM component modules
use Fcm::Timer;

# Function declarations
sub catfile;
sub basename;
sub dirname;

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

# Module level variables
my %unusual_tool_name = ();

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

MAIN: {
  # Name of program
  my $this = basename $0;

  # Arguments
  my $subcommand = shift @ARGV;
  my ($function, $type) = split /:/, $subcommand; 
  my ($srcpackage, $src, $target, $requirepp, @objects, @blockdata);
  
  if ($subcommand eq 'archive') {
    ($target, @objects) = @ARGV;

  } elsif ($subcommand eq 'load') {
    ($srcpackage, $src, $target, @blockdata) = @ARGV;

  } else {
    ($srcpackage, $src, $target, $requirepp) = @ARGV;
  }

  # Set up hash reference for all the required information
  my %info = (
    SRCPACKAGE => $srcpackage,
    SRC        => $src,
    TYPE       => $type,
    TARGET     => $target,
    REQUIREPP  => $requirepp,
    OBJECTS    => \@objects,
    BLOCKDATA  => \@blockdata,
  );

  # Get list of unusual tools
  my $i = 0;
  while (my $label = &get_env ('FCM_UNUSUAL_TOOL_LABEL' . $i)) {
    my $value = &get_env ('FCM_UNUSUAL_TOOL_VALUE' . $i);
    $unusual_tool_name{$label} = $value;
    $i++;
  }

  # Invoke the action
  my $rc = 0;
  if ($function eq 'compile') {
    $rc = &compile (\%info);

  } elsif ($function eq 'load') {
    $rc = &load (\%info);

  } elsif ($function eq 'archive') {
    $rc = &archive (\%info);

  } else {
    print STDERR $this, ': incorrect usage, abort';
    $rc = 1;
  }

  # Throw error if action failed
  if ($rc) {
    print STDERR $this, ' ', $function, ' failed (', $rc, ')', "\n";
    exit 1;

  } else {
    exit;
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = &compile (\%info);
#
# DESCRIPTION
#   This method invokes the correct compiler with the correct options to
#   compile the source file into the required target. The argument $info is a
#   hash reference set up in MAIN. The following environment variables are
#   used, where * is the source file type (F for Fortran, and C for C/C++):
# 
#   *C          - compiler command
#   *C_OUTPUT   - *C option to specify the name of the output file
#   *C_DEFINE   - *C option to declare a pre-processor def
#   *C_INCLUDE  - *C option to declare an include directory
#   *C_COMPILE  - *C option to ask the compiler to perform compile only
#   *CFLAGS     - *C user options
#   *PPKEYS     - list of pre-processor defs (may have sub-package suffix)
#   FCM_VERBOSE - verbose level
#   FCM_OBJDIR  - destination directory of object file
#   FCM_TMPDIR  - temporary destination directory of object file
# ------------------------------------------------------------------------------

sub compile {
  my $info = shift;

  # Verbose mode
  my $verbose = &get_env ('FCM_VERBOSE');
  $verbose    = 1 unless defined ($verbose);

  my @command = ();

  # Only support C and Fortran source files at the moment
  my $type = $info->{TYPE};
  $type    = ($info->{SRC} =~ /\.c(\w+)?$/i) ? 'C' : 'F' if not $type;

  # Compiler
  push @command, &get_env ($type . 'C', 1);

  # Compile output target (typical -o option)
  push @command, &get_env ($type . 'C_OUTPUT', 1), $info->{TARGET};

  # Pre-processor definition macros
  if ($info->{REQUIREPP}) {
    my @ppkeys = split /\s+/, &select_flags ($info, $type . 'PPKEYS');
    my $defopt = &get_env ($type . 'C_DEFINE', 1);

    push @command, (map {$defopt . $_} @ppkeys);
  }

  # Include search path
  my $incopt  = &get_env ($type . 'C_INCLUDE', 1);
  my @incpath = split /:/, &get_env ('FCM_INCPATH');
  push @command, (map {$incopt . $_} @incpath);

  # Other compiler flags
  my $flags = &select_flags ($info, $type . 'FLAGS');
  push @command, $flags if $flags;

  my $compile_only = &get_env ($type . 'C_COMPILE');
  if ($flags !~ /(?:^|\s)$compile_only\b/) {
    push @command, &get_env ($type . 'C_COMPILE');
  }

  # Name of source file
  push @command, $info->{SRC};

  # Execute command
  my $objdir = &get_env ('FCM_OBJDIR', 1);
  my $tmpdir = &get_env ('FCM_TMPDIR', 1);
  chdir $tmpdir;

  my $command = join ' ', @command;
  if ($verbose > 1) {
    print 'cd ', $tmpdir, "\n";
    print &timestamp_command ($command, 'Start');

  } elsif ($verbose) {
    print $command, "\n";
  }

  my $rc = system $command;

  print &timestamp_command ($command, 'End  ') if $verbose > 1;

  # Move temporary output to correct location on success
  # Otherwise, remove temporary output
  if ($rc) { # error
    unlink $info->{TARGET};

  } else {   # success
    print 'mv ', $info->{TARGET}, ' ', $objdir, "\n" if $verbose > 1;
    rename $info->{TARGET}, &catfile ($objdir, $info->{TARGET});
  }

  # Move any Fortran module definition files to the INC directory
  my @modfiles = <*.mod *.MOD>;
  for my $file (@modfiles) {
    rename $file, &catfile ($incpath[0], $file);
  }

  return $rc;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = &load (\%info);
#
# DESCRIPTION
#   This method invokes the correct loader with the correct options to link
#   the main program object into an executable. The argument $info is a hash
#   reference set up in MAIN. The following environment variables are used:
# 
#   LD           - linker command
#   LD_OUTPUT    - LD option to specify the name of the output file
#   LD_LIBSEARCH - LD option to declare a directory in the library search path
#   LD_LIBLINK   - LD option to declare an object library
#   LDFLAGS      - LD user options
#   FCM_VERBOSE  - verbose level
#   FCM_LIBDIR   - destination directory of object libraries
#   FCM_OBJDIR   - destination directory of object files
#   FCM_BINDIR   - destination directory of executable file
#   FCM_TMPDIR   - temporary destination directory of executable file
# ------------------------------------------------------------------------------

sub load {
  my $info = shift;

  my $rc = 0;

  # Verbose mode
  my $verbose = &get_env ('FCM_VERBOSE');
  $verbose    = 1 unless defined ($verbose);

  # Create temporary object library
  (my $name   = $info->{TARGET}) =~ s/\.\S+$//;
  my $libname = '__fcm__' . $name;
  my $lib     = 'lib' . $libname . '.a';
  my $libfile = catfile (&get_env ('FCM_LIBDIR', 1), $lib);
  $rc = &archive ({TARGET => $lib});

  unless ($rc) {
    my @command = ();

    # Linker
    push @command, &select_flags ($info, 'LD');

    # Linker output target (typical -o option)
    push @command, &get_env ('LD_OUTPUT', 1), $info->{TARGET};

    # Name of main object file
    my $mainobj = (basename ($info->{SRC}) eq $info->{SRC})
                  ? catfile (&get_env ('FCM_OBJDIR'), $info->{SRC})
                  : $info->{SRC};
    push @command, $mainobj;

    # Link with Fortran BLOCKDATA objects if necessary
    if (@{ $info->{BLOCKDATA} }) {
      my @blockdata = @{ $info->{BLOCKDATA} };
      my @objpath   = split /:/, &get_env ('FCM_OBJPATH');

      # Search each BLOCKDATA object file from the object search path
      for my $file (@blockdata) {
        for my $dir (@objpath) {
          my $full = catfile ($dir, $file);

          if (-r $full) {
            $file = $full;
            last;
          }
        }

        push @command, $file;
      }
    }

    # Library search path
    my $libopt  = &get_env ('LD_LIBSEARCH', 1);
    my @libpath = split /:/, &get_env ('FCM_LIBPATH');
    push @command, (map {$libopt . $_} @libpath);

    # Link with temporary object library if it exists
    push @command, &get_env ('LD_LIBLINK', 1) . $libname if -f $libfile;

    # Other linker flags
    my $flags = &select_flags ($info, 'LDFLAGS');
    push @command, $flags;

    # Execute command
    my $tmpdir = &get_env ('FCM_TMPDIR', 1);
    my $bindir = &get_env ('FCM_BINDIR', 1);
    chdir $tmpdir;

    my $command = join ' ', @command;
    if ($verbose > 1) {
      print 'cd ', $tmpdir, "\n";
      print &timestamp_command ($command, 'Start');

    } elsif ($verbose) {
      print $command, "\n";
    }

    $rc = system $command;

    print &timestamp_command ($command, 'End  ') if $verbose > 1;

    # Move temporary output to correct location on success
    # Otherwise, remove temporary output
    if ($rc) { # error
      unlink $info->{TARGET};

    } else {   # success
      print 'mv ', $info->{TARGET}, ' ', $bindir, "\n" if $verbose > 1;
      rename $info->{TARGET}, &catfile ($bindir, $info->{TARGET});
    }
  }

  # Remove the temporary object library
  unlink $libfile if -f $libfile;

  return $rc;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = &archive (\%info);
#
# DESCRIPTION
#   This method invokes the library archiver to create an object library. The
#   argument $info is a hash reference set up in MAIN. The following
#   environment variables are used:
# 
#   AR           - archiver command
#   ARFLAGS      - AR options to update/create an object library
#   FCM_VERBOSE  - verbose level
#   FCM_LIBDIR   - destination directory of object libraries
#   FCM_OBJPATH  - search path of object files
#   FCM_OBJDIR   - destination directory of object files
#   FCM_TMPDIR   - temporary destination directory of executable file
# ------------------------------------------------------------------------------

sub archive {
  my $info = shift;

  my $rc = 0;

  # Verbose mode
  my $verbose = &get_env ('FCM_VERBOSE');
  $verbose    = 1 unless defined ($verbose);

  # Set up the archive command
  my $lib     = &basename ($info->{TARGET});
  my $tmplib  = &catfile (&get_env ('FCM_TMPDIR', 1), $lib);
  my @ar_cmd  = ();
  push @ar_cmd, (&get_env ('AR', 1), &get_env ('ARFLAGS', 1));
  push @ar_cmd, $tmplib;

  # Get object directories and their files
  my %objdir;
  if (exists $info->{OBJECTS}) {
    # List of objects set in the argument, sort into directory/file list
    for my $name (@{ $info->{OBJECTS} }) {
      my $dir = (&dirname ($name) eq '.')
                ? &get_env ('FCM_OBJDIR', 1) : &dirname ($name);
      $objdir{$dir}{&basename ($name)} = 1;
    }

  } else {
    # Objects not listed in argument, search object path for all files
    my @objpath  = split /:/, &get_env ('FCM_OBJPATH', 1);
    my %objbase  = ();

    # Get registered objects into a hash (keys = objects, values = 1)
    my %objects = map {($_, 1)} split (/\s+/, &get_env ('OBJECTS'));

    # Seach object path for all files
    for my $dir (@objpath) {
      next unless -d $dir;

      chdir $dir;

      # Use all files from each directory in the object search path
      for ((glob ('*'))) {
        next unless exists $objects{$_}; # consider registered objects only
        $objdir{$dir}{$_} = 1 unless exists $objbase{$_};
        $objbase{$_} = 1;
      }
    }
  }

  for my $dir (keys %objdir) {
    next unless -d $dir;

    # Go to each object directory and executes the library archive command 
    chdir $dir;
    my $command = join ' ', (@ar_cmd, sort keys %{ $objdir{$dir} });

    if ($verbose > 1) {
      print 'cd ', $dir, "\n";
      print &timestamp_command ($command, 'Start');

    } else {
      print $command, "\n" if exists $info->{OBJECTS};
    }

    $rc = system $command;

    print &timestamp_command ($command, 'End  ')
      if $verbose > 1;
    last if $rc;
  }

  # Move temporary output to correct location on success
  # Otherwise, remove temporary output
  if ($rc) { # error
    unlink $tmplib;

  } else {   # success
    my $libdir = &get_env ('FCM_LIBDIR', 1);

    print 'mv ', $tmplib, ' ', $libdir, "\n" if $verbose > 1;
    rename $tmplib, &catfile ($libdir, $lib);
  }

  return $rc;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $flags = &select_flags (\%info, $set);
#
# DESCRIPTION
#   This function selects the correct compiler/linker flags for the current
#   sub-package from the environment variable prefix $set. The argument $info
#   is a hash reference set up in MAIN.
# ------------------------------------------------------------------------------

sub select_flags {
  my ($info, $set) = @_;

  (my $srcroot = &basename ($info->{SRC})) =~ s/\.\S+$//;
  my @names    = ($set);
  push @names, split (/__/, $info->{SRCPACKAGE} . '__' . $srcroot);

  my $string   = '';
  while (@names) {
    my $name = join '__', @names;
    my $var  = &get_env ($name);

    if (defined $var) {
      $string = $var;
      last;

    } else {
      pop @names;
    }
  }

  return $string;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $variable = &get_env ($name);
#   $variable = &get_env ($name, $compulsory);
#
# DESCRIPTION
#   This internal method gets a variable from $ENV{$name}. If $compulsory is
#   set to true, it throws an error if the variable is a not set or is an empty
#   string. Otherwise, it returns C<undef> if the variable is not set.
# ------------------------------------------------------------------------------

sub get_env {
  (my $name, my $compulsory) = @_;
  my $string;

  if ($name =~ /^\w+$/) {
    # $name contains only word characters, variable is exported normally
    die 'The environment variable "', $name, '" must be set, abort'
      if $compulsory and not exists $ENV{$name};

    $string = exists $ENV{$name} ? $ENV{$name} : undef;

  } else {
    # $name contains unusual characters
    die 'The environment variable "', $name, '" must be set, abort'
      if $compulsory and not exists $unusual_tool_name{$name};

    $string = exists $unusual_tool_name{$name}
              ? $unusual_tool_name{$name} : undef;
  }

  return $string;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $path = &catfile (@paths);
#
# DESCRIPTION
#   This is a local implementation of what is in the File::Spec module.
# ------------------------------------------------------------------------------

sub catfile {
  my @names = split (m!/!, join ('/', @_));
  my $path  = shift @names;

  for my $name (@names) {
    $path .= '/' . $name if $name;
  }

  return $path;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $basename = &basename ($path);
#
# DESCRIPTION
#   This is a local implementation of what is in the File::Basename module.
# ------------------------------------------------------------------------------

sub basename {
  my $name = $_[0];

  $name =~ s{/*$}{}; # remove trailing slashes

  if ($name =~ m#.*/([^/]+)$#) {
    return $1;

  } else {
    return $name;
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $dirname = &dirname ($path);
#
# DESCRIPTION
#   This is a local implementation of what is in the File::Basename module.
# ------------------------------------------------------------------------------

sub dirname {
  my $name = $_[0];

  if ($name =~ m#^/+$#) {
    return '/'; # dirname of root is root

  } else {
    $name =~ s{/*$}{}; # remove trailing slashes

    if ($name =~ m#^(.*)/[^/]+$#) {
      my $dir = $1;
      $dir =~ s{/*$}{}; # remove trailing slashes
      return $dir;

    } else {
      return '.';
    }
  }
}

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

__END__