source: OFFICIAL/FCM_V1.3/lib/Fcm/BuildSrc.pm

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

creation de larborescence
File size: 46.1 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   Fcm::BuildSrc
5#
6# DESCRIPTION
7#   This is a class to group functionalities of source in a build.
8#
9# COPYRIGHT
10#   (C) Crown copyright Met Office. All rights reserved.
11#   For further details please refer to the file COPYRIGHT.txt
12#   which you should have received as part of this distribution.
13# ------------------------------------------------------------------------------
14
15package Fcm::BuildSrc;
16@ISA = qw(Fcm::Base);
17
18# Standard pragma
19use strict;
20use warnings;
21
22# Standard modules
23use Carp;
24use Cwd;
25use File::Basename ('basename', 'dirname');
26use File::Spec;
27
28# ECMWF modules
29use Ecmwf::Fortran90_stuff;
30
31# FCM component modules
32use Fcm::Base;
33use Fcm::CfgFile;
34use Fcm::CfgLine;
35use Fcm::Config;
36use Fcm::Timer;
37use Fcm::Util;
38
39# List of scalar property methods for this class
40my @scalar_properties = (
41  'children',   # list of children packages
42  'is_updated', # is this source (or its associated settings) updated?
43  'mtime',      # modification time of src
44  'ppmtime',    # modification time of ppsrc
45  'ppsrc',      # full path of the pre-processed source
46  'pkgname',    # package name of the source
47  'progname',   # program unit name in the source
48  'src',        # full path of the source
49  'type',       # type of the source
50);
51
52# List of hash property methods for this class
53my @hash_properties = (
54  'dep',   # dependencies
55  'ppdep', # pre-process dependencies
56  'rules', # make rules
57);
58
59# ------------------------------------------------------------------------------
60# SYNOPSIS
61#   $obj = Fcm::BuildSrc->new (%args);
62#
63# DESCRIPTION
64#   This method constructs a new instance of the Fcm::BuildSrc class. See
65#   above for allowed list of properties. (KEYS should be in uppercase.)
66# ------------------------------------------------------------------------------
67
68sub new {
69  my $this  = shift;
70  my %args  = @_;
71  my $class = ref $this || $this;
72
73  my $self = Fcm::Base->new (%args);
74
75  for (@scalar_properties, @hash_properties) {
76    $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef;
77  }
78
79  bless $self, $class;
80  return $self;
81}
82
83# ------------------------------------------------------------------------------
84# SYNOPSIS
85#   $value = $obj->X;
86#   $obj->X ($value);
87#
88# DESCRIPTION
89#   Details of these properties are explained in @scalar_properties.
90# ------------------------------------------------------------------------------
91
92for my $name (@scalar_properties) {
93  no strict 'refs';
94
95  *$name = sub {
96    my $self = shift;
97
98    # Argument specified, set property to specified argument
99    if (@_) {
100      $self->{$name} = $_[0];
101
102      if ($name eq 'ppsrc') {
103        $self->ppmtime (undef);
104
105      } elsif ($name eq 'src') {
106        $self->mtime (undef);
107      }
108    }
109
110    # Default value for property
111    if (not defined $self->{$name}) {
112      if ($name eq 'children') {
113        # Reference to an empty array
114        $self->{$name} = [];
115       
116      } elsif ($name =~ /^(?:is_cur|pkgname|ppsrc|src)$/) {
117        # Empty string
118        $self->{$name} = '';
119       
120      } elsif ($name eq 'mtime') {
121        # Modification time
122        $self->{$name} = (stat $self->src)[9] if $self->src;
123       
124      } elsif ($name eq 'ppmtime') {
125        # Modification time
126        $self->{$name} = (stat $self->ppsrc)[9] if $self->ppsrc;
127       
128      } elsif ($name eq 'type') {
129        # Attempt to get the type if src is set
130        $self->{$name} = $self->get_type if $self->src;
131      }
132    }
133
134    return $self->{$name};
135  }
136}
137
138# ------------------------------------------------------------------------------
139# SYNOPSIS
140#   %hash = %{ $obj->X () };
141#   $obj->X (\%hash);
142#
143#   $value = $obj->X ($index);
144#   $obj->X ($index, $value);
145#
146# DESCRIPTION
147#   Details of these properties are explained in @hash_properties.
148#
149#   If no argument is set, this method returns a hash containing a list of
150#   objects. If an argument is set and it is a reference to a hash, the objects
151#   are replaced by the the specified hash.
152#
153#   If a scalar argument is specified, this method returns a reference to an
154#   object, if the indexed object exists or undef if the indexed object does
155#   not exist. If a second argument is set, the $index element of the hash will
156#   be set to the value of the argument.
157# ------------------------------------------------------------------------------
158
159for my $name (@hash_properties) {
160  no strict 'refs';
161
162  *$name = sub {
163    my ($self, $arg1, $arg2) = @_;
164
165    # Ensure property is defined as a reference to a hash
166    if (not defined $self->{$name}) {
167      if ($name eq 'rules') {
168        $self->{$name} = $self->get_rules;
169
170      } else {
171        $self->{$name} = {};
172      }
173    }
174
175    # Argument 1 can be a reference to a hash or a scalar index
176    my ($index, %hash);
177
178    if (defined $arg1) {
179      if (ref ($arg1) eq 'HASH') {
180        %hash = %$arg1;
181
182      } else {
183        $index = $arg1;
184      }
185    }
186
187    if (defined $index) {
188      # A scalar index is defined, set and/or return the value of an element
189      $self->{$name}{$index} = $arg2 if defined $arg2;
190
191      return (
192        exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
193      );
194
195    } else {
196      # A scalar index is not defined, set and/or return the hash
197      $self->{$name} = \%hash if defined $arg1;
198      return $self->{$name};
199    }
200  }
201}
202
203# ------------------------------------------------------------------------------
204# SYNOPSIS
205#   $value = $obj->X;
206#   $obj->X ($value);
207#
208# DESCRIPTION
209#   This method returns/sets property X, all derived from src, where X is:
210#     base  - (read-only) basename of src
211#     dir   - (read-only) dirname of src
212#     ext   - (read-only) file extension of src
213#     root  - (read-only) basename of src without the file extension
214# ------------------------------------------------------------------------------
215
216sub base {
217  return &basename ($_[0]->src);
218}
219
220# ------------------------------------------------------------------------------
221
222sub dir {
223  return &dirname ($_[0]->src);
224}
225
226# ------------------------------------------------------------------------------
227
228sub ext {
229  return substr $_[0]->base, length ($_[0]->root);
230}
231
232# ------------------------------------------------------------------------------
233
234sub root {
235  (my $root = $_[0]->base) =~ s/\.\w+$//;
236  return $root;
237}
238
239# ------------------------------------------------------------------------------
240# SYNOPSIS
241#   $value = $obj->X;
242#   $obj->X ($value);
243#
244# DESCRIPTION
245#   This method returns/sets property X, all derived from ppsrc, where X is:
246#     ppbase  - (read-only) basename of ppsrc
247#     ppdir   - (read-only) dirname of ppsrc
248#     ppext   - (read-only) file extension of ppsrc
249#     pproot  - (read-only) basename of ppsrc without the file extension
250# ------------------------------------------------------------------------------
251
252sub ppbase {
253  return &basename ($_[0]->ppsrc);
254}
255
256# ------------------------------------------------------------------------------
257
258sub ppdir {
259  return &dirname ($_[0]->ppsrc);
260}
261
262# ------------------------------------------------------------------------------
263
264sub ppext {
265  return substr $_[0]->ppbase, length ($_[0]->pproot);
266}
267
268# ------------------------------------------------------------------------------
269
270sub pproot {
271  (my $root = $_[0]->ppbase) =~ s/\.\w+$//;
272  return $root;
273}
274
275# ------------------------------------------------------------------------------
276# SYNOPSIS
277#   $value = $obj->X;
278#
279# DESCRIPTION
280#   This method returns/sets property X, derived from src or ppsrc, where X is:
281#     curbase  - (read-only) basename of cursrc
282#     curdir   - (read-only) dirname of cursrc
283#     curext   - (read-only) file extension of cursrc
284#     curmtime - (read-only) modification time of cursrc
285#     curroot  - (read-only) basename of cursrc without the file extension
286#     cursrc   - ppsrc or src
287# ------------------------------------------------------------------------------
288
289for my $name (qw/base dir ext mtime root src/) {
290  no strict 'refs';
291
292  my $subname = 'cur' . $name;
293
294  *$subname = sub {
295    my $self = shift;
296    my $method = $self->ppsrc ? 'pp' . $name : $name;
297    return $self->$method (@_);
298  }
299}
300
301# ------------------------------------------------------------------------------
302# SYNOPSIS
303#   $base = $obj->X ();
304#
305# DESCRIPTION
306#   This method returns a basename X for the source, where X is:
307#     donebase      - "done" file name
308#     etcbase       - target for copying data files
309#     exebase       - executable name for source containing a main program
310#     interfacebase - Fortran interface file name
311#     libbase       - library file name
312#     objbase       - object name for source containing compilable source
313#   If the source file contains a compilable procedure, this method returns
314#   the name of the object file.
315# ------------------------------------------------------------------------------
316
317sub donebase {
318  my $self   = shift;
319
320  my $return;
321  if ($self->is_type_all ('SOURCE')) {
322    if ($self->objbase and not $self->is_type_all ('PROGRAM')) {
323      $return = ($self->progname ? $self->progname : lc ($self->curroot)) .
324                $self->setting (qw/OUTFILE_EXT DONE/);
325    }
326
327  } elsif ($self->is_type_all ('INCLUDE')) {
328    $return = $self->curbase . $self->setting (qw/OUTFILE_EXT IDONE/);
329  }
330
331  return $return;
332}
333
334# ------------------------------------------------------------------------------
335
336sub etcbase {
337  my $self = shift;
338
339  my $return = @{ $self->children }
340               ? $self->pkgname . $self->setting (qw/OUTFILE_EXT ETC/)
341               : undef;
342
343  return $return;
344}
345
346# ------------------------------------------------------------------------------
347
348sub exebase {
349  my $self = shift;
350
351  my $return;
352  if ($self->objbase and $self->is_type_all ('PROGRAM')) {
353    if ($self->setting ('BLD_EXE_NAME', $self->curroot)) {
354      $return = $self->setting ('BLD_EXE_NAME', $self->curroot);
355
356    } else {
357      $return = $self->curroot . $self->setting (qw/OUTFILE_EXT EXE/);
358    }
359  }
360
361  return $return;
362}
363
364# ------------------------------------------------------------------------------
365
366sub interfacebase {
367  my $self   = shift;
368
369  my $return;
370  if ($self->objbase and $self->is_type_any (qw/FORTRAN FPP/) and
371      uc ($self->get_setting (qw/TOOL GENINTERFACE/)) ne 'NONE' and
372      not $self->is_type_any (qw/PROGRAM MODULE/)) {
373
374    my $flag = lc ($self->get_setting (qw/TOOL INTERFACE/));
375    my $ext  = $self->setting (qw/OUTFILE_EXT INTERFACE/);
376
377    $return = ($flag eq 'program' ? $self->progname : $self->curroot) . $ext;
378  }
379
380  return $return;
381}
382
383# ------------------------------------------------------------------------------
384
385sub objbase {
386  my $self = shift;
387
388  my $return;
389
390  if ($self->is_type_all ('SOURCE')) {
391    my $ext = $self->setting (qw/OUTFILE_EXT OBJ/);
392
393    if ($self->is_type_any (qw/FORTRAN FPP/)) {
394      $return = lc ($self->progname) . $ext if $self->progname;
395
396    } else {
397      $return = lc ($self->curroot) . $ext;
398    }
399  }
400
401  return $return;
402}
403
404# ------------------------------------------------------------------------------
405# SYNOPSIS
406#   $value = $obj->flagsbase ($flag, [$index,]);
407#
408# DESCRIPTION
409#   This method returns the property flagsbase (derived from pkgname) the base
410#   name of the flags-file (to indicate changes in a particular build tool) for
411#   $flag, which can have the value:
412#     *FLAGS  - compiler flags flags-file
413#     *PPKEYS - pre-processor keys (i.e. macro definitions) flags-file
414#     LD      - linker flags-file
415#     LDFLAGS - linker flags flags-file
416#   If $index is set, the $index'th element in pkgnames is used for the package
417#   name.
418# ------------------------------------------------------------------------------
419
420sub flagsbase {
421  my ($self, $flag, $index) = @_;
422
423  (my $pkg = $index ? $self->pkgnames->[$index] : $self->pkgname) =~ s/\.\w+$//;
424
425  if ($self->is_type_all ('SOURCE')) {
426    if ($flag eq 'FLAGS' or $flag eq 'PPKEYS' and $self->lang) {
427      my %tool_src = %{ $self->setting ('TOOL_SRC') };
428      $flag = $tool_src{$self->lang}{$flag} ? $tool_src{$self->lang}{$flag} : '';
429    }
430  }
431
432  if ($flag) {
433    return join ('__', ($flag, $pkg ? $pkg : ())) .
434           $self->setting (qw/OUTFILE_EXT FLAGS/);
435
436  } else {
437    return undef;
438  }
439}
440
441# ------------------------------------------------------------------------------
442# SYNOPSIS
443#   $value = $obj->libbase ([$prefix], [$suffix]);
444#
445# DESCRIPTION
446#   This method returns the property libbase (derived from pkgname) the base
447#   name of the library archive. $prefix and $suffix defaults to 'lib' and '.a'
448#   respectively.
449# ------------------------------------------------------------------------------
450
451sub libbase {
452  my ($self, $prefix, $suffix) = @_;
453
454  $prefix = 'lib' if not defined $prefix;
455  $suffix = $self->setting (qw/OUTFILE_EXT LIB/) if not defined $suffix;
456
457  my $return;
458  if (not $self->src) {
459    my $lib = $self->setting ('BLD_LIB', $self->pkgname)
460              ? $self->setting ('BLD_LIB', $self->pkgname)
461              : $self->pkgname;
462    $return = $prefix . $lib . $suffix;
463  }
464
465  return $return;
466}
467
468# ------------------------------------------------------------------------------
469# SYNOPSIS
470#   $value = $obj->lang ([$setting]);
471#
472# DESCRIPTION
473#   This method returns the property lang (derived from type) the programming
474#   language name if type matches one supported in the TOOL_SRC setting. If
475#   $setting is specified, use $setting instead of TOOL_SRC.
476# ------------------------------------------------------------------------------
477
478sub lang {
479  my ($self, $setting) = @_;
480
481  my @keys = keys %{ $self->setting ($setting ? $setting : 'TOOL_SRC') };
482
483  my $return = undef;
484  for my $key (@keys) {
485    next unless $self->is_type_all ('SOURCE', $key);
486    $return = $key;
487    last;
488  }
489
490  return $return;
491}
492
493# ------------------------------------------------------------------------------
494# SYNOPSIS
495#   $value = $obj->pkgnames;
496#
497# DESCRIPTION
498#   This method returns a list of container packages, derived from pkgname:
499# ------------------------------------------------------------------------------
500
501sub pkgnames {
502  my $self = shift;
503
504  my $return = [];
505  if ($self->pkgname) {
506    my @names = split (/__/, $self->pkgname);
507
508    for my $i (0 .. $#names) {
509      push @$return, join ('__', (@names[0 .. $i]));
510    }
511
512    unshift @$return, '';
513  }
514
515  return $return;
516}
517
518# ------------------------------------------------------------------------------
519# SYNOPSIS
520#   %dep = %{ $obj->get_dep ([$flag]) };
521#
522# DESCRIPTION
523#   This method scans the current source file for dependencies and returns the
524#   dependency hash (keys = dependencies, values = dependency types). If $flag
525#   is specified, the config setting for $flag is used to determine the types of
526#   types. Otherwise, those specified in 'BLD_TYPE_DEP' is used.
527# ------------------------------------------------------------------------------
528
529sub get_dep {
530  my ($self, $flag) = @_;
531
532  # Determine what dependencies are supported by this known type
533  my %types = %{ $self->setting ($flag ? $flag : 'BLD_TYPE_DEP') };
534
535  # Work out list of exclude for this file, using its sub-package name
536  my %exclude = map {$_, 1} @{ $self->get_setting ('BLD_DEP_EXCL') };
537
538  my @depends = ();
539  for my $key (keys %types) {
540    # Check if current file is a type of file requiring dependency scan
541    next unless $self->is_type_all ($key);
542   
543    # Get list of dependency type for this file
544    for my $depend ((split /$Fcm::Config::DELIMITER/, $types{$key})) {
545      # Ignore a dependency type if the dependency is in the exclude list
546      next if exists $exclude{$depend};
547
548      # Add to dependency list for current file
549      push @depends, $depend;
550    }
551  }
552
553  # Scan dependencies, if necessary ...
554  my %dep;
555  if (@depends) {
556    # Print diagnostic
557    print &timestamp_command ($self->pkgname . ': get dependency', 'Start')
558      if $self->verbose > 2;
559
560    open FILE, '<', $self->cursrc
561      or croak $self->cursrc, ': cannot open (', $!, '), abort';
562    my @lines = readline 'FILE';
563    close FILE;
564
565    # List of dependency patterns
566    my %dep_pattern = %{ $self->setting ('BLD_DEP_PATTERN') };
567
568    my $progname;
569    LINE: for my $line (@lines) {
570      # Ignore empty lines
571      next LINE if $line =~ /^\s*$/;
572
573      # Fortran source, also scan for program unit name
574      if (! $flag and ! $progname) {
575        if ($self->is_type_all (qw/SOURCE FPP/) or
576            $self->is_type_all (qw/SOURCE FORTRAN/)) {
577          my $pfx_pttn = '(?:(?:ELEMENTAL|(?:RECURSIVE(?:\s+PURE)?|' .
578                         'PURE(?:\s+RECURSIVE)?))\s+)?';
579          my $spc_pttn = '(?:(?:CHARACTER|COMPLEX|DOUBLE\s*PRECISION|INTEGER|' .
580                         'LOGICAL|REAL|TYPE)(?:\s*\(.+\)|\s*\*\d+\s*)??\s+)?';
581
582          if ($line =~ /^\s*PROGRAM\s+(\w+)/i) {
583            # Matches the beginning of a named main program
584            $progname = lc $1;
585            next LINE;
586
587          } elsif ($line =~ /^\s*MODULE\s+(\w+)/i) {
588            my $keyword = $1;
589
590            if (uc ($keyword) ne 'PROCEDURE') {
591              # Matches the beginning of a module
592              $progname = lc $keyword;
593              next LINE;
594            }
595
596          } elsif ($line =~ /^\s*BLOCK\s*DATA\s+(\w+)/i) {
597            # Matches the beginning of a named block data program unit
598            $progname = lc $1;
599            next LINE;
600
601          } elsif ($line =~ /^\s*$pfx_pttn SUBROUTINE\s+(\w+)/ix) {
602            # Matches the beginning of a subroutine
603            $progname = lc $1;
604            next LINE;
605
606          } elsif ($line =~ /^\s*$pfx_pttn $spc_pttn FUNCTION\s+(\w+)/ix) {
607            # Matches the beginning of a function
608            $progname = lc $1;
609            next LINE;
610          }
611        }
612      }
613
614      # Scan known dependencies
615      for my $depend (@depends) {
616        # Check if a pattern exists for the current dependency
617        next unless exists $dep_pattern{$depend};
618
619        # Attempt to match the pattern
620        my $pattern = $dep_pattern{$depend};
621
622        next unless $line =~ /$pattern/i;
623
624        my $match = $1;
625
626        # $match may contain multiple items delimited by space
627        for my $name (split /\s+/, $match) {
628          # Skip dependency if it is in the exclusion list
629          my $key = uc ($depend . $Fcm::Config::DELIMITER . $name);
630
631          next if exists $exclude{$key};
632
633          # Add this dependency to the list
634          $dep{$name} = $depend;
635        }
636
637        next LINE;
638      }
639    }
640
641    # Custom dependencies
642    my $custom_dep = $self->setting (
643      'BLD_DEP' . ($flag ? '_PP' : ''), $self->pkgname
644    );
645
646    if (defined $custom_dep) {
647      for (@$custom_dep) {
648        my ($type, $name) = split /$Fcm::Config::DELIMITER/;
649        $dep{$name} = $type;
650      }
651    }
652
653    $self->progname ($progname) if $progname;
654
655    # Diagnostic messages
656    if ($self->verbose > 2) {
657      my $base = $self->curbase;
658
659      my $ndep   = scalar (keys %dep);
660      my $nlines = scalar (@lines);
661      print $self->pkgname, ': ', $ndep, ' dependenc', ($ndep > 1 ? 'ies' : 'y'),
662            ' in ', $nlines, ' line', ($nlines > 1 ? 's' : ''), '.', "\n";
663      print &timestamp_command ($self->pkgname . ': get dependency', 'End');
664    }
665  }
666
667  return (@depends ? \%dep : undef);
668}
669
670# ------------------------------------------------------------------------------
671# SYNOPSIS
672#   @out = @{ $obj->get_fortran_interface () };
673#
674# DESCRIPTION
675#   This method invokes the Fortran interface block generator to generate
676#   an interface block for the current source file. It returns a reference to
677#   an array containing the lines of the interface block.
678# ------------------------------------------------------------------------------
679
680sub get_fortran_interface {
681  my $self = shift;
682
683  my $generator = $self->get_setting (qw/TOOL GENINTERFACE/);
684
685  my @outlines = ();
686  if ($generator eq 'f90aib') {
687    # Use F90AIB
688
689    # Open pipeline to interface file generator and read its output
690    my $devnull = File::Spec->devnull;
691    my $command = $generator;
692    $command   .= " <'" . $self->cursrc . "'" . " 2>'" . $devnull . "'";
693    my $croak   = $command . ' failed';
694
695    print &timestamp_command ($command, 'Start') if $self->verbose > 2;
696    open COMMAND, '-|', $command or croak $croak, ' (', $!, '), abort';
697    @outlines = readline 'COMMAND';
698    close COMMAND or croak $croak, ' (', $?, '), abort';
699    print &timestamp_command ($command, 'End  ') if $self->verbose > 2;
700
701  } elsif ($generator eq 'ECMWF') {
702    # Use ECMWF interface generator
703 
704    # Read source file into an array
705    open FILE, '<', $self->cursrc
706      or croak $self->cursrc, ': cannot open (', $!, '), abort';
707    my @src_lines = <FILE>;
708    close FILE;
709 
710    # Process standalone subroutines and functions only
711    if (not grep /^\s*(?:program|module)\b/i, @src_lines) {
712      print &timestamp_command ($self->cursrc . ': generating interface', 'Start')
713        if $self->verbose > 2;
714
715      my @statements = ();
716      my %prog_info  = ();
717 
718      # Set name of source file
719      &Ecmwf::Fortran90_stuff::fname ($self->cursrc);
720 
721      # Parse lines in source
722      &Ecmwf::Fortran90_stuff::setup_parse ();
723
724      # Expand continuation lines in source
725      &Ecmwf::Fortran90_stuff::expcont (\@src_lines, \@statements);
726 
727      # Analyse statements in source
728      $Ecmwf::Fortran90_stuff::study_called = 0;
729      &Ecmwf::Fortran90_stuff::study (\@statements, \%prog_info);
730 
731      # Source code is not a module
732      if (not $prog_info{is_module}) {
733        my @interface_block = ();
734        my @line_hash       = ();
735 
736        # Create an interface block for the program unit
737        &Ecmwf::Fortran90_stuff::create_interface_block (
738          \@statements,
739          \@interface_block,
740        );
741
742        # Put continuation lines back
743        &Ecmwf::Fortran90_stuff::cont_lines (
744          \@interface_block,
745          \@outlines,
746          \@line_hash,
747        );
748      }
749
750      print &timestamp_command ($self->cursrc . ': generating interface', 'End')
751        if $self->verbose > 2;
752    }
753
754  } elsif (uc ($generator) eq 'NONE') {
755    print $self->root, ': Fortran interface generation is switched off.', "\n"
756      if $self->verbose > 2;
757
758  } else {
759    e_report 'ERROR: Unknown Fortran 9x interface generator: ', $generator, '.';
760  }
761
762  return \@outlines;
763}
764
765# ------------------------------------------------------------------------------
766# SYNOPSIS
767#   @out = @{ $obj->get_pre_process () };
768#
769# DESCRIPTION
770#   This method invokes the pre-processor on the source file and returns a
771#   reference to an array containing the lines of the pre-processed source on
772#   success.
773# ------------------------------------------------------------------------------
774
775sub get_pre_process {
776  my $self = shift;
777
778  # Supported source files
779  my $lang = $self->lang ('TOOL_SRC_PP');
780  return unless $lang;
781
782  # List of include directories
783  my @inc = @{ $self->setting (qw/PATH INC/) };
784
785  # Build the pre-processor command according to file type
786  my %tool        = %{ $self->setting ('TOOL') };
787  my %tool_src_pp = %{ $self->setting ('TOOL_SRC_PP', $lang) };
788
789  # The pre-processor command and its options
790  my @command = ($tool{$tool_src_pp{COMMAND}});
791  my @ppflags = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{FLAGS});
792
793  # List of defined macros, add "-D" in front of each macro
794  my @ppkeys  = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{PPKEYS});
795  @ppkeys     = map {($tool{$tool_src_pp{DEFINE}}, $_)} @ppkeys;
796
797  # Add "-I" in front of each include directories
798  @inc        = map {($tool{$tool_src_pp{INCLUDE}}, $_)} @inc;
799
800  push @command, (@ppflags, @ppkeys, @inc, $self->base);
801
802  my $verbose = $self->verbose;
803  my $cwd     = cwd;
804
805  # Change to container directory of source file
806  print 'cd ', $self->dir, "\n" if $verbose > 1;
807  chdir $self->dir;
808
809  # Execute the command, getting the output lines
810  my @outlines = &run_command (
811    \@command, METHOD => 'qx', PRINT => $verbose > 1, TIME => $verbose > 2,
812  );
813
814  # Change back to original directory
815  print 'cd ', $cwd, "\n" if $self->verbose > 1;
816  chdir $cwd;
817
818  return \@outlines;
819}
820
821# ------------------------------------------------------------------------------
822# SYNOPSIS
823#   $rules = %{ $self->get_rules };
824#
825# DESCRIPTION
826#   This method returns a reference to a hash in the following format:
827#     $rules = {
828#       target => {ACTION => action, DEP => [dependencies], ...},
829#       ...    => {...},
830#     };
831#   where the 1st rank keys are the available targets for building this source
832#   file, the second rank keys are ACTION and DEP. The value of ACTION is the
833#   action for building the target, which can be "COMPILE", "LOAD", "TOUCH",
834#   "CP" or "AR". The value of DEP is a refernce to an array containing a list
835#   of dependencies suitable for insertion into the Makefile.
836# ------------------------------------------------------------------------------
837
838sub get_rules {
839  my $self = shift;
840
841  my $rules;
842  my %outfile_ext = %{ $self->setting ('OUTFILE_EXT') };
843
844  if ($self->is_type_all (qw/SOURCE/)) {
845    # Source file
846    # --------------------------------------------------------------------------
847    # Determine whether the language of the source file is supported
848    my %tool_src = %{ $self->setting ('TOOL_SRC') };
849
850    return () unless $self->lang;
851
852    # Compile object
853    # --------------------------------------------------------------------------
854    if ($self->objbase) {
855      # Depends on the source file
856      my @dep = ($self->rule_src);
857
858      # Depends on the compiler flags flags-file
859      my @flags;
860      push @flags, ('FLAGS' )
861        if $self->flagsbase ('FLAGS' );
862      push @flags, ('PPKEYS')
863        if $self->flagsbase ('PPKEYS') and not $self->ppsrc;
864
865      push @dep, $self->flagsbase ($_) for (@flags);
866
867      # Source file dependencies
868      for my $name (sort keys %{ $self->dep }) {
869        # A Fortran 9X module, lower case object file name
870        if ($self->dep ($name) eq 'USE') {
871          (my $root = $name) =~ s/\.\w+$//;
872          push @dep, lc ($root) . $outfile_ext{OBJ};
873
874        # An include file
875        } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
876          push @dep, $name;
877        }
878      }
879
880      $rules->{$self->objbase} = {ACTION => 'COMPILE', DEP => \@dep};
881
882      # Touch flags-files
883      # ------------------------------------------------------------------------
884      for my $flag (@flags) {
885        next unless $self->flagsbase ($flag);
886
887        $rules->{$self->flagsbase ($flag)} = {
888          ACTION => 'TOUCH',
889          DEP    => [
890            $self->flagsbase ($tool_src{$self->lang}{$flag}, -2),
891          ],
892          DEST   => '$(FCM_FLAGSDIR)',
893        };
894      }
895    }
896
897    if ($self->exebase) {
898      # Link into an executable
899      # ------------------------------------------------------------------------
900      my @dep = ();
901      push @dep, $self->objbase               if $self->objbase;
902      push @dep, $self->flagsbase ('LD'     ) if $self->flagsbase ('LD'     );
903      push @dep, $self->flagsbase ('LDFLAGS') if $self->flagsbase ('LDFLAGS');
904
905      # Depends on BLOCKDATA program units, for Fortran programs
906      my %blockdata = %{ $self->setting ('BLD_BLOCKDATA') };
907      my @blkobj    = ();
908
909      if ($self->is_type_any (qw/FPP FORTRAN/) and keys %blockdata) {
910        # List of BLOCKDATA object files
911        if (exists $blockdata{$self->exebase}) {
912          @blkobj = split /\s+/, $blockdata{$self->exebase};
913
914        } elsif (exists $blockdata{''}) {
915          @blkobj = split /\s+/, $blockdata{''};
916        }
917
918        for my $name (@blkobj) {
919          (my $root = $name) =~ s/\.\w+$//;
920          $name = $root . $outfile_ext{OBJ};
921          push @dep, $root . $outfile_ext{DONE};
922        }
923      }
924
925      # Extra executable dependencies
926      my %exe_dep = %{ $self->setting ('BLD_DEP_EXE') };
927      if (keys %exe_dep) {
928        my @exe_deps;
929        if (exists $exe_dep{$self->exebase}) {
930          @exe_deps = split /\s+/, $exe_dep{$self->exebase};
931
932        } elsif (exists $exe_dep{''}) {
933          @exe_deps = $exe_dep{''} ? split (/\s+/, $exe_dep{''}) : ('');
934        }
935
936        my $pattern = '\\' . $outfile_ext{OBJ} . '$';
937
938        for my $name (@exe_deps) {
939          if ($name =~ /$pattern/) {
940            # Extra dependency is an object
941            (my $root = $name) =~ s/\.\w+$//;
942            push @dep, $root . $outfile_ext{DONE};
943
944          } else {
945            # Extra dependency is a sub-package
946            my $var;
947            if ($self->setting ('FCM_PCK_OBJECTS', $name)) {
948              # sub-package name contains unusual characters
949              $var = $self->setting ('FCM_PCK_OBJECTS', $name);
950
951            } else {
952              # sub-package name contains normal characters
953              $var = $name ? join ('__', ('OBJECTS', $name)) : 'OBJECTS';
954            }
955
956            push @dep, '$(' . $var . ')';
957          }
958        }
959      }
960
961      # Source file dependencies
962      for my $name (sort keys %{ $self->dep }) {
963        (my $root = $name) =~ s/\.\w+$//;
964
965        # Lowercase name for object dependency
966        $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
967
968        # Select "done" file extension
969        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
970          push @dep, $name . $outfile_ext{IDONE};
971
972        } else {
973          push @dep, $root . $outfile_ext{DONE};
974        }
975      }
976
977      $rules->{$self->exebase} = {
978        ACTION => 'LOAD', DEP => \@dep, BLOCKDATA => \@blkobj,
979      };
980
981      # Touch Linker flags-file
982      # ------------------------------------------------------------------------
983      for my $flag (qw/LD LDFLAGS/) {
984        $rules->{$self->flagsbase ($flag)} = {
985          ACTION => 'TOUCH',
986          DEP    => [$self->flagsbase ($flag, -2)],
987          DEST   => '$(FCM_FLAGSDIR)',
988        };
989      }
990
991    }
992
993    if ($self->donebase) {
994      # Touch done file
995      # ------------------------------------------------------------------------
996      my @dep = ($self->objbase);
997
998      for my $name (sort keys %{ $self->dep }) {
999        (my $root = $name) =~ s/\.\w+$//;
1000
1001        # Lowercase name for object dependency
1002        $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
1003
1004        # Select "done" file extension
1005        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
1006          push @dep, $name . $outfile_ext{IDONE};
1007
1008        } else {
1009          push @dep, $root . $outfile_ext{DONE};
1010        }
1011      }
1012
1013      $rules->{$self->donebase} = {
1014        ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
1015      };
1016    }
1017   
1018    if ($self->interfacebase) {
1019      # Interface target
1020      # ------------------------------------------------------------------------
1021      # Source file dependencies
1022      my @dep = ();
1023      for my $name (sort keys %{ $self->dep }) {
1024        # Depends on Fortran 9X modules
1025        push @dep, lc ($name) . $outfile_ext{OBJ}
1026          if $self->dep ($name) eq 'USE';
1027      }
1028
1029      $rules->{$self->interfacebase} = {ACTION => '', DEP => \@dep};
1030    }
1031
1032  } elsif ($self->is_type_all ('INCLUDE')) {
1033    # Copy include target
1034    # --------------------------------------------------------------------------
1035    my @dep = ($self->rule_src);
1036
1037    for my $name (sort keys %{ $self->dep }) {
1038      # A Fortran 9X module, lower case object file name
1039      if ($self->dep ($name) eq 'USE') {
1040        (my $root = $name) =~ s/\.\w+$//;
1041        push @dep, lc ($root) . $outfile_ext{OBJ};
1042
1043      # An include file
1044      } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
1045        push @dep, $name;
1046      }
1047    }
1048
1049    $rules->{$self->curbase} = {
1050      ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_INCDIR)',
1051    };
1052
1053    # Touch IDONE file
1054    # --------------------------------------------------------------------------
1055    if ($self->donebase) {
1056      my @dep = ($self->rule_src);
1057
1058      for my $name (sort keys %{ $self->dep }) {
1059        (my $root = $name) =~ s/\.\w+$//;
1060
1061        # Lowercase name for object dependency
1062        $root   = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
1063
1064        # Select "done" file extension
1065        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
1066          push @dep, $name . $outfile_ext{IDONE};
1067
1068        } else {
1069          push @dep, $root . $outfile_ext{DONE};
1070        }
1071      }
1072
1073      $rules->{$self->donebase} = {
1074        ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
1075      };
1076    }
1077
1078  } elsif ($self->is_type_any (qw/EXE SCRIPT/)) {
1079    # Copy executable file
1080    # --------------------------------------------------------------------------
1081    my @dep = ($self->rule_src);
1082
1083    # Depends on dummy copy file, if file is an "always build type"
1084    push @dep, $self->setting (qw/BLD_CPDUMMY/)
1085      if $self->is_type_any (split (
1086        /$Fcm::Config::DELIMITER_LIST/, $self->setting ('BLD_TYPE_ALWAYS_BUILD')
1087      ));
1088
1089    # Depends on other executable files
1090    for my $name (sort keys %{ $self->dep }) {
1091      push @dep, $name if $self->dep ($name) eq 'EXE';
1092    }
1093
1094    $rules->{$self->curbase} = {
1095      ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_BINDIR)',
1096    };
1097
1098  } elsif (@{ $self->children }) {
1099    # Targets for top level and package flags files and dummy dependencies
1100    # --------------------------------------------------------------------------
1101    my %tool_src   = %{ $self->setting ('TOOL_SRC') };
1102    my %flags_tool = (LD => '', LDFLAGS => '');
1103
1104    for my $key (keys %tool_src) {
1105      $flags_tool{$tool_src{$key}{FLAGS}} = $tool_src{$key}{COMMAND}
1106        if exists $tool_src{$key}{FLAGS};
1107
1108      $flags_tool{$tool_src{$key}{PPKEYS}} = ''
1109        if exists $tool_src{$key}{PPKEYS};
1110    }
1111
1112    for my $name (sort keys %flags_tool) {
1113      my @dep = $self->pkgname eq '' ? () : $self->flagsbase ($name, -2);
1114      push @dep, $self->flagsbase ($flags_tool{$name})
1115        if $self->pkgname eq '' and $flags_tool{$name};
1116
1117      $rules->{$self->flagsbase ($flags_tool{$name})} = {
1118        ACTION => 'TOUCH',
1119        DEST   => '$(FCM_FLAGSDIR)',
1120      } if $self->pkgname eq '' and $flags_tool{$name};
1121
1122      $rules->{$self->flagsbase ($name)} = {
1123        ACTION => 'TOUCH',
1124        DEP    => \@dep,
1125        DEST   => '$(FCM_FLAGSDIR)',
1126      };
1127    }
1128
1129    # Package object and library
1130    # --------------------------------------------------------------------------
1131    {
1132      my @dep;
1133      # Add objects from children
1134      for my $child (sort {$a->pkgname cmp $b->pkgname} @{ $self->children }) {
1135        push @dep, $child->rule_obj_var (1)
1136          if $child->libbase and $child->rules ($child->libbase);
1137        push @dep, $child->objbase
1138          if $child->cursrc and $child->objbase and
1139             not $child->is_type_any (qw/PROGRAM BLOCKDATA/);
1140      }
1141
1142      if (@dep) {
1143        $rules->{$self->libbase} = {ACTION => 'AR', DEP => \@dep};
1144      }
1145    }
1146
1147    # Package data files
1148    # --------------------------------------------------------------------------
1149    {
1150      my @dep;
1151      for my $child (@{ $self->children }) {
1152        push @dep, $child->rule_src if $child->src and not $child->type;
1153      }
1154
1155      if (@dep) {
1156        push @dep, $self->setting (qw/BLD_CPDUMMY/);
1157        $rules->{$self->etcbase} = {
1158          ACTION => 'CP_DATA', DEP => \@dep, DEST => '$(FCM_ETCDIR)',
1159        };
1160      }
1161    }
1162  }
1163
1164  return $rules;
1165}
1166
1167# ------------------------------------------------------------------------------
1168# SYNOPSIS
1169#   $value = $obj->get_setting ($setting[, @prefix]);
1170#
1171# DESCRIPTION
1172#   This method gets the correct $setting for the current source by following
1173#   its package name. If @prefix is set, get the setting with the given prefix.
1174# ------------------------------------------------------------------------------
1175
1176sub get_setting {
1177  my ($self, $setting, @prefix) = @_;
1178
1179  my $val;
1180  for my $name (reverse @{ $self->pkgnames }) {
1181    my @names = split /__/, $name;
1182    $val = $self->setting ($setting, join ('__', (@prefix, @names)));
1183
1184    $val = $self->setting ($setting, join ('__', (@prefix, @names)))
1185      if (not defined $val) and @names and $names[-1] =~ s/\.[^\.]+$//;
1186    last if defined $val;
1187  }
1188
1189  return $val;
1190}
1191
1192# ------------------------------------------------------------------------------
1193# SYNOPSIS
1194#   $type = $self->get_type;
1195#
1196# DESCRIPTION
1197#   This method determines whether the source is a type known to the
1198#   build system. If so, it returns the type flags delimited by "::".
1199# ------------------------------------------------------------------------------
1200
1201sub get_type {
1202  my $self = shift;
1203  my $type = $self->setting ('BLD_TYPE', $self->pkgname);
1204
1205  # Do not set a type if the file name matches the "ignore" list
1206  for ((split /$Fcm::Config::DELIMITER_LIST/, $self->setting ('INFILE_IGNORE')))
1207  {
1208    next unless $self->curbase eq $_;
1209    $type = '';
1210    last;
1211  }
1212
1213  if (not defined $type) {
1214    # Determine file type by comparing its extension with supported ones
1215    my $ext = $self->curext ? substr ($self->curext, 1) : '';
1216    $type = $self->setting ('INFILE_EXT', $ext);
1217  }
1218
1219  if (not defined $type) {
1220    # Determine file type by comparing its name with known patterns
1221    for my $pat (keys %{ $self->setting ('INFILE_PAT') }) {
1222      next unless $self->curbase =~ /$pat/;
1223      $type = $self->setting ('INFILE_PAT', $pat);
1224      last;
1225    }
1226  }
1227
1228  if (-s $self->cursrc and -T $self->cursrc and not defined $type) {
1229    # Determine file type by inspecting its first line (text file only)
1230    if (open SRC, '<', $self->cursrc) {
1231      my $line = <SRC>;
1232      close SRC;
1233
1234      for my $txt (keys %{ $self->setting ('INFILE_TXT') }) {
1235        next unless $line =~ /^#!.*$txt/;
1236        $type = $self->setting ('INFILE_TXT', $txt);
1237        last;
1238      }
1239    }
1240  }
1241
1242  if ($type and $type =~ /(?:^|::)(?:FORTRAN|FPP)(?:::|$)/) {
1243    # Determine whether source file is a main Fortran program or module
1244    if (open SRC, '<', $self->cursrc) {
1245      while (my $line = <SRC>) {
1246        if ($line =~ /^\s*(PROGRAM|MODULE)\b/i) {
1247          $type .= $Fcm::Config::DELIMITER . uc ($1);
1248          last;
1249
1250        } elsif ($line =~ /^\s*BLOCK\s*DATA\b/i) {
1251          $type .= $Fcm::Config::DELIMITER . 'BLOCKDATA';
1252          last;
1253        }
1254      }
1255      close SRC;
1256    }
1257
1258  } elsif ($type and $type =~ /(?:^|::)C(?:::|$)/) {
1259    # Determine whether source file is a main C program
1260    if (open SRC, '<', $self->cursrc) {
1261      while (my $line = <SRC>) {
1262        next unless $line =~ /int\s*main\s*\(/i;
1263        $type .= $Fcm::Config::DELIMITER . 'PROGRAM';
1264        last;
1265      }
1266      close SRC;
1267    }
1268  }
1269
1270  return $type;
1271}
1272
1273# ------------------------------------------------------------------------------
1274# SYNOPSIS
1275#   $flag = $obj->is_in_package ($name);
1276#
1277# DESCRIPTION
1278#   This method returns true if current package is in the package $name.
1279# ------------------------------------------------------------------------------
1280
1281sub is_in_package {
1282  my ($self, $name) = @_;
1283 
1284  my $return = 0;
1285  for (@{ $self->pkgnames }) {
1286    next unless /^$name(?:\.\w+)?$/;
1287    $return = 1;
1288    last;
1289  }
1290
1291  return $return;
1292}
1293
1294# ------------------------------------------------------------------------------
1295# SYNOPSIS
1296#   $flag = $obj->is_type_all ($arg, ...);
1297#   $flag = $obj->is_type_any ($arg, ...);
1298#
1299# DESCRIPTION
1300#   This method returns a flag for the following:
1301#     is_type_all - does type match all of the arguments?
1302#     is_type_any - does type match any of the arguments?
1303# ------------------------------------------------------------------------------
1304
1305for my $name ('all', 'any') {
1306  no strict 'refs';
1307
1308  my $subname = 'is_type_' . $name;
1309
1310  *$subname = sub {
1311    my ($self, @intypes) = @_;
1312
1313    my $rc = 0;
1314    if ($self->type) {
1315      my %types = map {($_, 1)} split /$Fcm::Config::DELIMITER/, $self->type;
1316
1317      for my $intype (@intypes) {
1318        $rc = exists $types{$intype};
1319        last if ($name eq 'all' and not $rc) or ($name eq 'any' and $rc);
1320      }
1321    }
1322
1323    return $rc;
1324  }
1325}
1326
1327# ------------------------------------------------------------------------------
1328# SYNOPSIS
1329#   $string = $obj->rule_obj_var ([$read]);
1330#
1331# DESCRIPTION
1332#   This method returns a string containing the make rule object variable for
1333#   the current package. If $read is set, return $($string)
1334# ------------------------------------------------------------------------------
1335
1336sub rule_obj_var {
1337  my ($self, $read) = @_;
1338
1339  my $return;
1340  if ($self->setting ('FCM_PCK_OBJECTS', $self->pkgname)) {
1341    # Package name registered in unusual list
1342    $return = $self->setting ('FCM_PCK_OBJECTS', $self->pkgname);
1343
1344  } else {
1345    # Package name not registered in unusual list
1346    $return = $self->pkgname
1347              ? join ('__', ('OBJECTS', $self->pkgname)) : 'OBJECTS';
1348  }
1349
1350  $return = $read ? '$(' . $return . ')' : $return;
1351
1352  return $return;
1353}
1354
1355# ------------------------------------------------------------------------------
1356# SYNOPSIS
1357#   $string = $obj->rule_src ();
1358#
1359# DESCRIPTION
1360#   This method returns a string containing the location of the source file
1361#   relative to the build root. This string will be suitable for use in a
1362#   "Make" rule file for FCM.
1363# ------------------------------------------------------------------------------
1364
1365sub rule_src {
1366  my $self = shift;
1367
1368  my $return = $self->cursrc;
1369  LABEL: for my $name (qw/SRC PPSRC/) {
1370    for my $i (0 .. @{ $self->setting ('PATH', $name) } - 1) {
1371      my $dir = $self->setting ('PATH', $name)->[$i];
1372      next unless index ($self->cursrc, $dir) == 0;
1373
1374      $return = File::Spec->catfile (
1375        '$(FCM_' . $name . 'DIR' . ($i ? $i : '') . ')',
1376        File::Spec->abs2rel ($self->cursrc, $dir),
1377      );
1378      last LABEL;
1379    }
1380  }
1381
1382  return $return;
1383}
1384
1385# ------------------------------------------------------------------------------
1386# SYNOPSIS
1387#   $rc = $obj->write_lib_dep_excl ();
1388#
1389# DESCRIPTION
1390#   This method writes a set of exclude dependency configurations for the
1391#   library of this package.
1392# ------------------------------------------------------------------------------
1393
1394sub write_lib_dep_excl {
1395  my $self = shift;
1396
1397  my $rc = 1;
1398
1399  return 0 unless &find_file_in_path (
1400    $self->libbase, $self->setting (qw/PATH LIB/)
1401  );
1402
1403  my $cfg = Fcm::CfgFile->new;
1404
1405  # Include configurations from sub-packages
1406  my $etcdir = $self->setting (qw/PATH ETC/)->[0];
1407  my $cfgext = $self->setting (qw/OUTFILE_EXT CFG/);
1408  my $label  = $self->cfglabel ('BLD_DEP_EXCL');
1409
1410  for my $child (sort {$a->pkgname cmp $b->pkgname} @{ $self->children }) {
1411    my $file = File::Spec->catfile ('$HERE', $child->libbase ('lib', $cfgext));
1412    push @{$cfg->lines}, Fcm::CfgLine->new (
1413      label => $self->cfglabel ('INC'), value => $file
1414    ) if -r File::Spec->catfile ($etcdir, $child->libbase ('lib', $cfgext));
1415  }
1416
1417  # Exclude dependency for source files in current package
1418  for my $child (@{ $self->children }) {
1419    next unless $child->cursrc and $child->type;
1420
1421    if ($child->is_type_all ('INCLUDE')) {
1422      if ($child->is_type_all ('CPP')) {
1423        push @{$cfg->lines}, Fcm::CfgLine->new (
1424          label => $label,
1425          value => 'H' . $Fcm::Config::DELIMITER . $child->base,
1426        );
1427
1428      } elsif ($child->is_type_all ('INTERFACE')) {
1429        push @{$cfg->lines}, Fcm::CfgLine->new (
1430          label => $label,
1431          value => 'INTERFACE' . $Fcm::Config::DELIMITER . $child->base,
1432        );
1433
1434      } else {
1435        push @{$cfg->lines}, Fcm::CfgLine->new (
1436          label => $label,
1437          value => 'INC' . $Fcm::Config::DELIMITER . $child->base,
1438        );
1439      }
1440
1441    } elsif ($child->is_type_all ('SOURCE')) {
1442      next if $child->is_type_any (qw/PROGRAM BLOCKDATA/);
1443
1444      if ($child->is_type_all ('FORTRAN')) {
1445        if ($child->is_type_all (qw/FORTRAN MODULE/)) {
1446          push @{$cfg->lines}, Fcm::CfgLine->new (
1447            label => $label,
1448            value => 'USE' . $Fcm::Config::DELIMITER . $child->root,
1449          );
1450
1451        } else {
1452          push @{$cfg->lines}, Fcm::CfgLine->new (
1453            label => $label,
1454            value => 'INTERFACE'
1455                     . $Fcm::Config::DELIMITER . $child->interfacebase,
1456          ) if $child->interfacebase;
1457
1458          push @{$cfg->lines}, Fcm::CfgLine->new (
1459            label => $label,
1460            value => 'OBJ' . $Fcm::Config::DELIMITER . $child->root,
1461          );
1462        }
1463
1464      } else {
1465        push @{$cfg->lines}, Fcm::CfgLine->new (
1466          label => $label,
1467          value => 'OBJ' . $Fcm::Config::DELIMITER . $child->root,
1468        );
1469      }
1470    }
1471  }
1472
1473  # Write to configuration file
1474  my $outfile = File::Spec->catfile ($etcdir, $self->libbase ('lib', $cfgext));
1475  $rc = $cfg->print_cfg ($outfile);
1476
1477  return $rc;
1478}
1479
1480# ------------------------------------------------------------------------------
1481# SYNOPSIS
1482#   $string = $obj->write_rules ();
1483#
1484# DESCRIPTION
1485#   This method returns a string containing the "Make" rules for building the
1486#   source file.
1487# ------------------------------------------------------------------------------
1488
1489sub write_rules {
1490  my $self  = shift;
1491  my $mk    = '';
1492
1493  for my $target (sort keys %{ $self->rules }) {
1494    my $rule = $self->rules ($target);
1495    next unless defined ($rule->{ACTION});
1496
1497    if ($rule->{ACTION} eq 'AR') {
1498      my $var = $self->rule_obj_var;
1499      $mk .= ($var eq 'OBJECTS' ? 'export ' : '') . $var . ' =';
1500      $mk .= ' ' . join (' ', @{ $rule->{DEP} });
1501      $mk .= "\n\n";
1502    }
1503
1504    $mk .= $target . ':';
1505   
1506    if ($rule->{ACTION} eq 'AR') {
1507      $mk .= ' ' . $self->rule_obj_var (1);
1508
1509    } else {
1510      for my $dep (@{ $rule->{DEP} }) {
1511        $mk .= ' ' . $dep;
1512      }
1513    }
1514
1515    $mk .= "\n";
1516
1517    if (exists $rule->{ACTION}) {
1518      if ($rule->{ACTION} eq 'AR') {
1519        $mk .= "\t" . 'fcm_internal archive $@ $^' . "\n";
1520
1521      } elsif ($rule->{ACTION} eq 'CP') {
1522        $mk .= "\t" . 'cp $< ' . $rule->{DEST} . "\n";
1523        $mk .= "\t" . 'chmod u+w ' .
1524               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1525
1526      } elsif ($rule->{ACTION} eq 'CP_DATA') {
1527        $mk .= "\t" . 'cp $^ ' . $rule->{DEST} . "\n";
1528        $mk .= "\t" . 'touch ' .
1529               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1530
1531      } elsif ($rule->{ACTION} eq 'COMPILE') {
1532        if ($self->lang) {
1533          $mk .= "\t" . 'fcm_internal compile:' . substr ($self->lang, 0, 1) .
1534                 ' ' . $self->pkgnames->[-2] . ' $< $@';
1535          $mk .= ' 1' if ($self->flagsbase ('PPKEYS') and not $self->ppsrc);
1536          $mk .= "\n";
1537        }
1538
1539      } elsif ($rule->{ACTION} eq 'LOAD') {
1540        if ($self->lang) {
1541          $mk .= "\t" . 'fcm_internal load:' . substr ($self->lang, 0, 1) .
1542                 ' ' . $self->pkgnames->[-2] . ' $< $@';
1543          $mk .= ' ' . join (' ', @{ $rule->{BLOCKDATA} })
1544            if @{ $rule->{BLOCKDATA} };
1545          $mk .= "\n";
1546        }
1547
1548      } elsif ($rule->{ACTION} eq 'TOUCH') {
1549        $mk .= "\t" . 'touch ' .
1550               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1551      }
1552    }
1553
1554    $mk .= "\n";
1555  }
1556
1557  return $mk;
1558}
1559
1560# ------------------------------------------------------------------------------
1561
15621;
1563
1564__END__
Note: See TracBrowser for help on using the repository browser.