source: PATCHED/FCM_V1.2/bin/fcm_internal @ 2

Last change on this file since 2 was 1, checked in by fcm, 15 years ago

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