source: branches/UKMO/r6232_tracer_advection/NEMOGCM/EXTERNAL/fcm/bin/fcm_internal @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 3 years ago

Remove svn keywords

File size: 17.8 KB
Line 
1#!/usr/bin/env perl
2#-------------------------------------------------------------------------------
3# (C) Crown copyright Met Office. All rights reserved.
4# For further details please refer to the file COPYRIGHT.txt
5# which you should have received as part of this distribution.
6#-------------------------------------------------------------------------------
7
8use strict;
9use warnings;
10
11use Fcm::Timer qw{timestamp_command};
12
13# Function declarations
14sub catfile;
15sub basename;
16sub dirname;
17
18# ------------------------------------------------------------------------------
19
20# Module level variables
21my %unusual_tool_name = ();
22
23# ------------------------------------------------------------------------------
24
25MAIN: {
26  # Name of program
27  my $this = basename $0;
28
29  # Arguments
30  my $subcommand = shift @ARGV;
31  my ($function, $type) = split /:/, $subcommand; 
32
33  my ($srcpackage, $src, $target, $requirepp, @objects, @blockdata);
34 
35  if ($function eq 'archive') {
36    ($target, @objects) = @ARGV;
37
38  } elsif ($function eq 'load') {
39    ($srcpackage, $src, $target, @blockdata) = @ARGV;
40
41  } else {
42    ($srcpackage, $src, $target, $requirepp) = @ARGV;
43  }
44
45  # Set up hash reference for all the required information
46  my %info = (
47    SRCPACKAGE => $srcpackage,
48    SRC        => $src,
49    TYPE       => $type,
50    TARGET     => $target,
51    REQUIREPP  => $requirepp,
52    OBJECTS    => \@objects,
53    BLOCKDATA  => \@blockdata,
54  );
55
56  # Get list of unusual tools
57  my $i = 0;
58  while (my $label = &get_env ('FCM_UNUSUAL_TOOL_LABEL' . $i)) {
59    my $value = &get_env ('FCM_UNUSUAL_TOOL_VALUE' . $i);
60    $unusual_tool_name{$label} = $value;
61    $i++;
62  }
63
64  # Invoke the action
65  my $rc = 0;
66  if ($function eq 'compile') {
67    $rc = &compile (\%info);
68
69  } elsif ($function eq 'load') {
70    $rc = &load (\%info);
71
72  } elsif ($function eq 'archive') {
73    $rc = &archive (\%info);
74
75  } else {
76    print STDERR $this, ': incorrect usage, abort';
77    $rc = 1;
78  }
79
80  # Throw error if action failed
81  if ($rc) {
82    print STDERR $this, ' ', $function, ' failed (', $rc, ')', "\n";
83    exit 1;
84
85  } else {
86    exit;
87  }
88}
89
90# ------------------------------------------------------------------------------
91# SYNOPSIS
92#   $rc = &compile (\%info);
93#
94# DESCRIPTION
95#   This method invokes the correct compiler with the correct options to
96#   compile the source file into the required target. The argument $info is a
97#   hash reference set up in MAIN. The following environment variables are
98#   used, where * is the source file type (F for Fortran, and C for C/C++):
99#
100#   *C          - compiler command
101#   *C_OUTPUT   - *C option to specify the name of the output file
102#   *C_DEFINE   - *C option to declare a pre-processor def
103#   *C_INCLUDE  - *C option to declare an include directory
104#   *C_MODSEARCH- *C option to declare a module search directory
105#   *C_COMPILE  - *C option to ask the compiler to perform compile only
106#   *CFLAGS     - *C user options
107#   *PPKEYS     - list of pre-processor defs (may have sub-package suffix)
108#   FCM_VERBOSE - verbose level
109#   FCM_OBJDIR  - destination directory of object file
110#   FCM_TMPDIR  - temporary destination directory of object file
111# ------------------------------------------------------------------------------
112
113sub compile {
114  my $info = shift;
115
116  # Verbose mode
117  my $verbose = &get_env ('FCM_VERBOSE');
118  $verbose    = 1 unless defined ($verbose);
119
120  my @command = ();
121
122  # Guess file type for backward compatibility
123  my $type = $info->{TYPE} ? $info->{TYPE} : &guess_file_type ($info->{SRC});
124
125  # Compiler
126  push @command, &get_env ($type . 'C', 1);
127
128  # Compile output target (typical -o option)
129  push @command, &get_env ($type . 'C_OUTPUT', 1), $info->{TARGET};
130
131  # Pre-processor definition macros
132  if ($info->{REQUIREPP}) {
133    my @ppkeys = split /\s+/, &select_flags ($info, $type . 'PPKEYS');
134    my $defopt = &get_env ($type . 'C_DEFINE', 1);
135
136    push @command, (map {$defopt . $_} @ppkeys);
137  }
138
139  # Include search path
140  my $incopt  = &get_env ($type . 'C_INCLUDE', 1);
141  my @incpath = split /:/, &get_env ('FCM_INCPATH');
142  push @command, (map {$incopt . $_} @incpath);
143
144  # Compiled module search path
145  my $modopt  = &get_env ($type . 'C_MODSEARCH');
146  if ($modopt) {
147    push @command, (map {$modopt . $_} @incpath);
148  }
149
150  # Other compiler flags
151  my $flags = &select_flags ($info, $type . 'FLAGS');
152  push @command, $flags if $flags;
153
154  my $compile_only = &get_env ($type . 'C_COMPILE');
155  if ($flags !~ /(?:^|\s)$compile_only\b/) {
156    push @command, &get_env ($type . 'C_COMPILE');
157  }
158
159  # Name of source file
160  push @command, $info->{SRC};
161
162  # Execute command
163  my $objdir = &get_env ('FCM_OBJDIR', 1);
164  my $tmpdir = &get_env ('FCM_TMPDIR', 1);
165  chdir $tmpdir;
166
167  my $command = join ' ', @command;
168  if ($verbose > 1) {
169    print 'cd ', $tmpdir, "\n";
170    print &timestamp_command ($command, 'Start');
171
172  } elsif ($verbose) {
173    print $command, "\n";
174  }
175
176  my $rc = system $command;
177
178  print &timestamp_command ($command, 'End  ') if $verbose > 1;
179
180  # Move temporary output to correct location on success
181  # Otherwise, remove temporary output
182  if ($rc) { # error
183    unlink $info->{TARGET};
184
185  } else {   # success
186    print 'mv ', $info->{TARGET}, ' ', $objdir, "\n" if $verbose > 1;
187    rename $info->{TARGET}, &catfile ($objdir, $info->{TARGET});
188  }
189
190  # Move any Fortran module definition files to the INC directory
191  my @modfiles = <*.mod *.MOD>;
192  for my $file (@modfiles) {
193    rename $file, &catfile ($incpath[0], $file);
194  }
195
196  return $rc;
197}
198
199# ------------------------------------------------------------------------------
200# SYNOPSIS
201#   $rc = &load (\%info);
202#
203# DESCRIPTION
204#   This method invokes the correct loader with the correct options to link
205#   the main program object into an executable. The argument $info is a hash
206#   reference set up in MAIN. The following environment variables are used:
207#
208#   LD           - * linker command
209#   LD_OUTPUT    - LD option to specify the name of the output file
210#   LD_LIBSEARCH - LD option to declare a directory in the library search path
211#   LD_LIBLINK   - LD option to declare an object library
212#   LDFLAGS      - LD user options
213#   FCM_VERBOSE  - verbose level
214#   FCM_LIBDIR   - destination directory of object libraries
215#   FCM_OBJDIR   - destination directory of object files
216#   FCM_BINDIR   - destination directory of executable file
217#   FCM_TMPDIR   - temporary destination directory of executable file
218#
219#   * If LD is not set, it will attempt to guess the file type and use the
220#     compiler as the linker.
221# ------------------------------------------------------------------------------
222
223sub load {
224  my $info = shift;
225
226  my $rc = 0;
227
228  # Verbose mode
229  my $verbose = &get_env ('FCM_VERBOSE');
230  $verbose    = 1 unless defined ($verbose);
231
232  # Create temporary object library
233  (my $name   = $info->{TARGET}) =~ s/\.\S+$//;
234  my $libname = '__fcm__' . $name;
235  my $lib     = 'lib' . $libname . '.a';
236  my $libfile = catfile (&get_env ('FCM_LIBDIR', 1), $lib);
237  $rc = &archive ({TARGET => $lib});
238
239  unless ($rc) {
240    my @command = ();
241
242    # Linker
243    my $ld = &select_flags ($info, 'LD');
244    if (not $ld) {
245      # Guess file type for backward compatibility
246      my $type = $info->{TYPE} ? $info->{TYPE} : &guess_file_type ($info->{SRC});
247      $ld = &get_env ($type . 'C', 1);
248    }
249    push @command, $ld;
250
251    # Linker output target (typical -o option)
252    push @command, &get_env ('LD_OUTPUT', 1), $info->{TARGET};
253
254    # Name of main object file
255    my $mainobj = (basename ($info->{SRC}) eq $info->{SRC})
256                  ? catfile (&get_env ('FCM_OBJDIR'), $info->{SRC})
257                  : $info->{SRC};
258    push @command, $mainobj;
259
260    # Link with Fortran BLOCKDATA objects if necessary
261    if (@{ $info->{BLOCKDATA} }) {
262      my @blockdata = @{ $info->{BLOCKDATA} };
263      my @objpath   = split /:/, &get_env ('FCM_OBJPATH');
264
265      # Search each BLOCKDATA object file from the object search path
266      for my $file (@blockdata) {
267        for my $dir (@objpath) {
268          my $full = catfile ($dir, $file);
269
270          if (-r $full) {
271            $file = $full;
272            last;
273          }
274        }
275
276        push @command, $file;
277      }
278    }
279
280    # Library search path
281    my $libopt  = &get_env ('LD_LIBSEARCH', 1);
282    my @libpath = split /:/, &get_env ('FCM_LIBPATH');
283    push @command, (map {$libopt . $_} @libpath);
284
285    # Link with temporary object library if it exists
286    push @command, &get_env ('LD_LIBLINK', 1) . $libname if -f $libfile;
287
288    # Other linker flags
289    my $flags = &select_flags ($info, 'LDFLAGS');
290    push @command, $flags;
291
292    # Execute command
293    my $tmpdir = &get_env ('FCM_TMPDIR', 1);
294    my $bindir = &get_env ('FCM_BINDIR', 1);
295    chdir $tmpdir;
296
297    my $command = join ' ', @command;
298    if ($verbose > 1) {
299      print 'cd ', $tmpdir, "\n";
300      print &timestamp_command ($command, 'Start');
301
302    } elsif ($verbose) {
303      print $command, "\n";
304    }
305
306    $rc = system $command;
307
308    print &timestamp_command ($command, 'End  ') if $verbose > 1;
309
310    # Move temporary output to correct location on success
311    # Otherwise, remove temporary output
312    if ($rc) { # error
313      unlink $info->{TARGET};
314
315    } else {   # success
316      print 'mv ', $info->{TARGET}, ' ', $bindir, "\n" if $verbose > 1;
317      rename $info->{TARGET}, &catfile ($bindir, $info->{TARGET});
318    }
319  }
320
321  # Remove the temporary object library
322  unlink $libfile if -f $libfile;
323
324  return $rc;
325}
326
327# ------------------------------------------------------------------------------
328# SYNOPSIS
329#   $rc = &archive (\%info);
330#
331# DESCRIPTION
332#   This method invokes the library archiver to create an object library. The
333#   argument $info is a hash reference set up in MAIN. The following
334#   environment variables are used:
335#
336#   AR           - archiver command
337#   ARFLAGS      - AR options to update/create an object library
338#   FCM_VERBOSE  - verbose level
339#   FCM_LIBDIR   - destination directory of object libraries
340#   FCM_OBJPATH  - search path of object files
341#   FCM_OBJDIR   - destination directory of object files
342#   FCM_TMPDIR   - temporary destination directory of executable file
343# ------------------------------------------------------------------------------
344
345sub archive {
346  my $info = shift;
347
348  my $rc = 0;
349
350  # Verbose mode
351  my $verbose = &get_env ('FCM_VERBOSE');
352  $verbose    = 1 unless defined ($verbose);
353
354  # Set up the archive command
355  my $lib     = &basename ($info->{TARGET});
356  my $tmplib  = &catfile (&get_env ('FCM_TMPDIR', 1), $lib);
357  my @ar_cmd  = ();
358  push @ar_cmd, (&get_env ('AR', 1), &get_env ('ARFLAGS', 1));
359  push @ar_cmd, $tmplib;
360
361  # Get object directories and their files
362  my %objdir;
363  if (exists $info->{OBJECTS}) {
364    # List of objects set in the argument, sort into directory/file list
365    for my $name (@{ $info->{OBJECTS} }) {
366      my $dir = (&dirname ($name) eq '.')
367                ? &get_env ('FCM_OBJDIR', 1) : &dirname ($name);
368      $objdir{$dir}{&basename ($name)} = 1;
369    }
370
371  } else {
372    # Objects not listed in argument, search object path for all files
373    my @objpath  = split /:/, &get_env ('FCM_OBJPATH', 1);
374    my %objbase  = ();
375
376    # Get registered objects into a hash (keys = objects, values = 1)
377    my %objects = map {($_, 1)} split (/\s+/, &get_env ('OBJECTS'));
378
379    # Seach object path for all files
380    for my $dir (@objpath) {
381      next unless -d $dir;
382
383      chdir $dir;
384
385      # Use all files from each directory in the object search path
386      for ((glob ('*'))) {
387        next unless exists $objects{$_}; # consider registered objects only
388        $objdir{$dir}{$_} = 1 unless exists $objbase{$_};
389        $objbase{$_} = 1;
390      }
391    }
392  }
393
394  for my $dir (sort keys %objdir) {
395    next unless -d $dir;
396
397    # Go to each object directory and executes the library archive command
398    chdir $dir;
399    my $command = join ' ', (@ar_cmd, sort keys %{ $objdir{$dir} });
400
401    if ($verbose > 1) {
402      print 'cd ', $dir, "\n";
403      print &timestamp_command ($command, 'Start');
404
405    } else {
406      print $command, "\n" if exists $info->{OBJECTS};
407    }
408
409    $rc = system $command;
410
411    print &timestamp_command ($command, 'End  ')
412      if $verbose > 1;
413    last if $rc;
414  }
415
416  # Move temporary output to correct location on success
417  # Otherwise, remove temporary output
418  if ($rc) { # error
419    unlink $tmplib;
420
421  } else {   # success
422    my $libdir = &get_env ('FCM_LIBDIR', 1);
423
424    print 'mv ', $tmplib, ' ', $libdir, "\n" if $verbose > 1;
425    rename $tmplib, &catfile ($libdir, $lib);
426  }
427
428  return $rc;
429}
430
431# ------------------------------------------------------------------------------
432# SYNOPSIS
433#   $type = &guess_file_type ($filename);
434#
435# DESCRIPTION
436#   This function attempts to guess the file type by looking at the extension
437#   of the $filename. Only C and Fortran at the moment.
438# ------------------------------------------------------------------------------
439
440sub guess_file_type {
441  return (($_[0] =~ /\.c(\w+)?$/i) ? 'C' : 'F');
442}
443
444# ------------------------------------------------------------------------------
445# SYNOPSIS
446#   $flags = &select_flags (\%info, $set);
447#
448# DESCRIPTION
449#   This function selects the correct compiler/linker flags for the current
450#   sub-package from the environment variable prefix $set. The argument $info
451#   is a hash reference set up in MAIN.
452# ------------------------------------------------------------------------------
453
454sub select_flags {
455  my ($info, $set) = @_;
456
457  my $srcbase = &basename ($info->{SRC});
458  my @names    = ($set);
459  push @names, split (/__/, $info->{SRCPACKAGE} . '__' . $srcbase);
460
461  my $string = '';
462  for my $i (reverse (0 .. $#names)) {
463    my $var  = &get_env (join ('__', (@names[0 .. $i])));
464
465    $var = &get_env (join ('__', (@names[0 .. $i])))
466      if (not defined ($var)) and $i and $names[-1] =~ s/\.[^\.]+$//;
467
468    next unless defined $var;
469    $string = $var;
470    last;
471  }
472
473  return $string;
474}
475
476# ------------------------------------------------------------------------------
477# SYNOPSIS
478#   $variable = &get_env ($name);
479#   $variable = &get_env ($name, $compulsory);
480#
481# DESCRIPTION
482#   This internal method gets a variable from $ENV{$name}. If $compulsory is
483#   set to true, it throws an error if the variable is a not set or is an empty
484#   string. Otherwise, it returns C<undef> if the variable is not set.
485# ------------------------------------------------------------------------------
486
487sub get_env {
488  (my $name, my $compulsory) = @_;
489  my $string;
490
491  if ($name =~ /^\w+$/) {
492    # $name contains only word characters, variable is exported normally
493    die 'The environment variable "', $name, '" must be set, abort'
494      if $compulsory and not exists $ENV{$name};
495
496    $string = exists $ENV{$name} ? $ENV{$name} : undef;
497
498  } else {
499    # $name contains unusual characters
500    die 'The environment variable "', $name, '" must be set, abort'
501      if $compulsory and not exists $unusual_tool_name{$name};
502
503    $string = exists $unusual_tool_name{$name}
504              ? $unusual_tool_name{$name} : undef;
505  }
506
507  return $string;
508}
509
510# ------------------------------------------------------------------------------
511# SYNOPSIS
512#   $path = &catfile (@paths);
513#
514# DESCRIPTION
515#   This is a local implementation of what is in the File::Spec module.
516# ------------------------------------------------------------------------------
517
518sub catfile {
519  my @names = split (m!/!, join ('/', @_));
520  my $path  = shift @names;
521
522  for my $name (@names) {
523    $path .= '/' . $name if $name;
524  }
525
526  return $path;
527}
528
529# ------------------------------------------------------------------------------
530# SYNOPSIS
531#   $basename = &basename ($path);
532#
533# DESCRIPTION
534#   This is a local implementation of what is in the File::Basename module.
535# ------------------------------------------------------------------------------
536
537sub basename {
538  my $name = $_[0];
539
540  $name =~ s{/*$}{}; # remove trailing slashes
541
542  if ($name =~ m#.*/([^/]+)$#) {
543    return $1;
544
545  } else {
546    return $name;
547  }
548}
549
550# ------------------------------------------------------------------------------
551# SYNOPSIS
552#   $dirname = &dirname ($path);
553#
554# DESCRIPTION
555#   This is a local implementation of what is in the File::Basename module.
556# ------------------------------------------------------------------------------
557
558sub dirname {
559  my $name = $_[0];
560
561  if ($name =~ m#^/+$#) {
562    return '/'; # dirname of root is root
563
564  } else {
565    $name =~ s{/*$}{}; # remove trailing slashes
566
567    if ($name =~ m#^(.*)/[^/]+$#) {
568      my $dir = $1;
569      $dir =~ s{/*$}{}; # remove trailing slashes
570      return $dir;
571
572    } else {
573      return '.';
574    }
575  }
576}
577
578# ------------------------------------------------------------------------------
579
580__END__
581
582=head1 NAME
583
584fcm_internal
585
586=head1 SYNOPSIS
587
588    fcm_internal SUBCOMMAND ARGS
589
590=head1 DESCRIPTION
591
592The fcm_internal command is a frontend for some of the internal commands of
593the FCM build system. The subcommand can be "compile", "load" or "archive"
594for invoking the compiler, loader and library archiver respectively. If
595"compile" or "load" is specified, it can be suffixed with ":TYPE" to
596specify the nature of the source file. If TYPE is not specified, it is set
597to C if the file extension begins with ".c". For all other file types, it
598is set to F (for Fortran source). For compile and load, the other arguments
599are 1) the name of the container package of the source file, 2) the path to
600the source file and 3) the target name after compiling or loading the
601source file. For compile, the 4th argument is a flag to indicate whether
602pre-processing is required for compiling the source file.  For load, the
6034th and the rest of the arguments is a list of object files that cannot be
604archived into the temporary load library and must be linked into the target
605through the linker command. (E.g. Fortran BLOCKDATA program units must be
606linked this way.) If archive is specified, the first argument should be the
607name of the library archive target and the rest should be the object files
608to be included in the archive. This command is invoked via the build system
609and should never be called directly by the user.
610
611=head1 COPYRIGHT
612
613(C) Crown copyright Met Office. All rights reserved.
614
615=cut
Note: See TracBrowser for help on using the repository browser.