source: OFFICIAL/FCM_V1.3/bin/fcm_internal @ 7

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

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