New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
BuildSrc.pm in vendors/FCM/lib/Fcm – NEMO

source: vendors/FCM/lib/Fcm/BuildSrc.pm @ 10134

Last change on this file since 10134 was 10134, checked in by dguibert, 6 years ago

fcm: fix fortran interface generation with perl 5.12+

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