source: branches/UKMO/r6232_tracer_advection/NEMOGCM/EXTERNAL/fcm/lib/Fcm/BuildSrc.pm @ 9295

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

Remove svn keywords

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        uc($self->get_setting(qw/TOOL GENINTERFACE/)) ne 'NONE'
398    &&  $self->progname()
399    &&  $self->is_type_all(qw/SOURCE/)
400    &&  $self->is_type_any(qw/FORTRAN9X FPP9X/)
401    &&  !$self->is_type_any(qw/PROGRAM MODULE BLOCKDATA/)
402  ) {
403    my $flag = lc($self->get_setting(qw/TOOL INTERFACE/));
404    my $ext  = $self->setting(qw/OUTFILE_EXT INTERFACE/);
405
406    return (($flag eq 'program' ? $self->progname() : $self->curroot()) . $ext);
407  }
408  return;
409}
410
411# ------------------------------------------------------------------------------
412
413sub objbase {
414  my $self = shift;
415
416  my $return;
417
418  if ($self->is_type_all ('SOURCE')) {
419    my $ext = $self->setting (qw/OUTFILE_EXT OBJ/);
420
421    if ($self->is_type_any (qw/FORTRAN FPP/)) {
422      $return = lc ($self->progname) . $ext if $self->progname;
423
424    } else {
425      $return = lc ($self->curroot) . $ext;
426    }
427  }
428
429  return $return;
430}
431
432# ------------------------------------------------------------------------------
433# SYNOPSIS
434#   $value = $obj->flagsbase ($flag, [$index,]);
435#
436# DESCRIPTION
437#   This method returns the property flagsbase (derived from pkgname) the base
438#   name of the flags-file (to indicate changes in a particular build tool) for
439#   $flag, which can have the value:
440#     *FLAGS  - compiler flags flags-file
441#     *PPKEYS - pre-processor keys (i.e. macro definitions) flags-file
442#     LD      - linker flags-file
443#     LDFLAGS - linker flags flags-file
444#   If $index is set, the $index'th element in pkgnames is used for the package
445#   name.
446# ------------------------------------------------------------------------------
447
448sub flagsbase {
449  my ($self, $flag, $index) = @_;
450
451  (my $pkg = $index ? $self->pkgnames->[$index] : $self->pkgname) =~ s/\.\w+$//;
452
453  if ($self->is_type_all ('SOURCE')) {
454    if ($flag eq 'FLAGS' or $flag eq 'PPKEYS' and $self->lang) {
455      my %tool_src = %{ $self->setting ('TOOL_SRC') };
456      $flag = $tool_src{$self->lang}{$flag} ? $tool_src{$self->lang}{$flag} : '';
457    }
458  }
459
460  if ($flag) {
461    return join ('__', ($flag, $pkg ? $pkg : ())) .
462           $self->setting (qw/OUTFILE_EXT FLAGS/);
463
464  } else {
465    return undef;
466  }
467}
468
469# ------------------------------------------------------------------------------
470# SYNOPSIS
471#   $value = $obj->libbase ([$prefix], [$suffix]);
472#
473# DESCRIPTION
474#   This method returns the property libbase (derived from pkgname) the base
475#   name of the library archive. $prefix and $suffix defaults to 'lib' and '.a'
476#   respectively.
477# ------------------------------------------------------------------------------
478
479sub libbase {
480  my ($self, $prefix, $suffix) = @_;
481  $prefix ||= 'lib';
482  $suffix ||= $self->setting(qw/OUTFILE_EXT LIB/);
483  if ($self->src()) { # applies to directories only
484    return;
485  }
486  my $name = $self->setting('BLD_LIB', $self->pkgname());
487  if (!defined($name)) {
488    $name = $self->pkgname();
489  }
490  $prefix . $name . $suffix;
491}
492
493# ------------------------------------------------------------------------------
494# SYNOPSIS
495#   $value = $obj->lang ([$setting]);
496#
497# DESCRIPTION
498#   This method returns the property lang (derived from type) the programming
499#   language name if type matches one supported in the TOOL_SRC setting. If
500#   $setting is specified, use $setting instead of TOOL_SRC.
501# ------------------------------------------------------------------------------
502
503sub lang {
504  my ($self, $setting) = @_;
505
506  my @keys = keys %{ $self->setting ($setting ? $setting : 'TOOL_SRC') };
507
508  my $return = undef;
509  for my $key (@keys) {
510    next unless $self->is_type_all ('SOURCE', $key);
511    $return = $key;
512    last;
513  }
514
515  return $return;
516}
517
518# ------------------------------------------------------------------------------
519# SYNOPSIS
520#   $value = $obj->pkgnames;
521#
522# DESCRIPTION
523#   This method returns a list of container packages, derived from pkgname:
524# ------------------------------------------------------------------------------
525
526sub pkgnames {
527  my $self = shift;
528
529  my $return = [];
530  if ($self->pkgname) {
531    my @names = split (/__/, $self->pkgname);
532
533    for my $i (0 .. $#names) {
534      push @$return, join ('__', (@names[0 .. $i]));
535    }
536
537    unshift @$return, '';
538  }
539
540  return $return;
541}
542
543# ------------------------------------------------------------------------------
544# SYNOPSIS
545#   %dep = %{$obj->get_dep()};
546#   %dep = %{$obj->get_dep($flag)};
547#
548# DESCRIPTION
549#   This method scans the current source file for dependencies and returns the
550#   dependency hash (keys = dependencies, values = dependency types). If $flag
551#   is specified, the config setting for $flag is used to determine the types of
552#   types. Otherwise, those specified in 'BLD_TYPE_DEP' is used.
553# ------------------------------------------------------------------------------
554
555sub get_dep {
556  my ($self, $flag) = @_;
557  # Work out list of exclude for this file, using its sub-package name
558  my %EXCLUDE_SET = map {($_, 1)} @{$self->get_setting('BLD_DEP_EXCL')};
559  # Determine what dependencies are supported by this known type
560  my %DEP_TYPE_OF = %{$self->setting($flag ? $flag : 'BLD_TYPE_DEP')};
561  my %PATTERN_OF = %{$self->setting('BLD_DEP_PATTERN')};
562  my @dep_types = ();
563  if (!$self->get_setting('BLD_DEP_N')) {
564    DEP_TYPE:
565    while (my ($key, $dep_type_string) = each(%DEP_TYPE_OF)) {
566      # Check if current file is a type of file requiring dependency scan
567      if (!$self->is_type_all($key)) {
568        next DEP_TYPE;
569      }
570      # Get list of dependency type for this file
571      for my $dep_type (split(/$Fcm::Config::DELIMITER/, $dep_type_string)) {
572        if (exists($PATTERN_OF{$dep_type}) && !exists($EXCLUDE_SET{$dep_type})) {
573          push(@dep_types, $dep_type);
574        }
575      }
576    }
577  }
578
579  # Automatic dependencies
580  my %dep_of;
581  my $can_get_symbol # Also scan for program unit name in Fortran source
582      =  !$flag
583      && $self->is_type_all('SOURCE')
584      && $self->is_type_any(qw/FPP FORTRAN/)
585      ;
586  my $has_read_file;
587  if ($can_get_symbol || @dep_types) {
588    my $handle = _open($self->cursrc());
589    LINE:
590    while (my $line = readline($handle)) {
591      chomp($line);
592      if ($line =~ qr{\A \s* \z}msx) { # empty lines
593        next LINE;
594      }
595      if ($can_get_symbol) {
596        my $symbol = _get_dep_symbol($line);
597        if ($symbol) {
598          $self->progname($symbol);
599          $can_get_symbol = 0;
600          next LINE;
601        }
602      }
603      DEP_TYPE:
604      for my $dep_type (@dep_types) {
605        my ($match) = $line =~ /$PATTERN_OF{$dep_type}/i;
606        if (!$match) {
607          next DEP_TYPE;
608        }
609        # $match may contain multiple items delimited by space
610        for my $item (split(qr{\s+}msx, $match)) {
611          my $key = uc($dep_type . $Fcm::Config::DELIMITER . $item);
612          if (!exists($EXCLUDE_SET{$key})) {
613            $dep_of{$item} = $dep_type;
614          }
615        }
616        next LINE;
617      }
618    }
619    $self->_event('GET_DEPENDENCY', $self->pkgname(), $., scalar(keys(%dep_of)));
620    close($handle);
621    $has_read_file = 1;
622  }
623
624  # Manual dependencies
625  my $manual_deps_ref
626      = $self->setting('BLD_DEP' . ($flag ? '_PP' : ''), $self->pkgname());
627  if (defined($manual_deps_ref)) {
628    for (@{$manual_deps_ref}) {
629      my ($dep_type, $item) = split(/$Fcm::Config::DELIMITER/, $_, 2);
630      $dep_of{$item} = $dep_type;
631    }
632  }
633
634  return ($has_read_file, \%dep_of);
635}
636
637# Returns, if possible, the program unit declared in the $line.
638sub _get_dep_symbol {
639  my $line = shift();
640  for my $pattern (
641    qr{\A \s* $RE_OF{F_PREFIX} SUBROUTINE              \s+ ([A-Za-z]\w*)}imsx,
642    qr{\A \s* MODULE (?!\s+PROCEDURE)                  \s+ ([A-Za-z]\w*)}imsx,
643    qr{\A \s* PROGRAM                                  \s+ ([A-Za-z]\w*)}imsx,
644    qr{\A \s* $RE_OF{F_PREFIX} $RE_OF{F_SPEC} FUNCTION \s+ ([A-Za-z]\w*)}imsx,
645    qr{\A \s* BLOCK\s*DATA                             \s+ ([A-Za-z]\w*)}imsx,
646  ) {
647    my ($match) = $line =~ $pattern;
648    if ($match) {
649      return lc($match);
650    }
651  }
652  return;
653}
654
655# ------------------------------------------------------------------------------
656# SYNOPSIS
657#   @out = @{ $obj->get_fortran_interface () };
658#
659# DESCRIPTION
660#   This method invokes the Fortran interface block generator to generate
661#   an interface block for the current source file. It returns a reference to
662#   an array containing the lines of the interface block.
663# ------------------------------------------------------------------------------
664
665sub get_fortran_interface {
666  my $self = shift();
667  my %ACTION_OF = (
668    q{}    => \&_get_fortran_interface_by_internal_code,
669    f90aib => \&_get_fortran_interface_by_f90aib,
670    none   => sub {$self->_event('F_INTERFACE_NONE', $self->root()); []},
671  );
672  my $key = lc($self->get_setting(qw/TOOL GENINTERFACE/));
673  if (!$key || !exists($ACTION_OF{$key})) {
674    $key = q{};
675  }
676  $ACTION_OF{$key}->($self->cursrc());
677}
678
679# Generates Fortran interface block using "f90aib".
680sub _get_fortran_interface_by_f90aib {
681  my $path = shift();
682  my $command = sprintf(q{f90aib <'%s' 2>'%s'}, $path, File::Spec->devnull());
683  my $pipe = _open($command, '-|');
684  my @lines = readline($pipe);
685  close($pipe) || croak($ERR_MESS_OF{CLOSE_PIPE}, $command, $?);
686  \@lines;
687}
688
689# Generates Fortran interface block using internal code.
690sub _get_fortran_interface_by_internal_code {
691  my $path = shift();
692  my $handle = _open($path);
693  my @lines = _get_fortran_util()->extract_interface($handle);
694  close($handle);
695  \@lines;
696}
697
698# ------------------------------------------------------------------------------
699# SYNOPSIS
700#   @out = @{ $obj->get_pre_process () };
701#
702# DESCRIPTION
703#   This method invokes the pre-processor on the source file and returns a
704#   reference to an array containing the lines of the pre-processed source on
705#   success.
706# ------------------------------------------------------------------------------
707
708sub get_pre_process {
709  my $self = shift;
710
711  # Supported source files
712  my $lang = $self->lang ('TOOL_SRC_PP');
713  return unless $lang;
714
715  # List of include directories
716  my @inc = @{ $self->setting (qw/PATH INC/) };
717
718  # Build the pre-processor command according to file type
719  my %tool        = %{ $self->setting ('TOOL') };
720  my %tool_src_pp = %{ $self->setting ('TOOL_SRC_PP', $lang) };
721
722  # The pre-processor command and its options
723  my @command = ($tool{$tool_src_pp{COMMAND}});
724  my @ppflags = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{FLAGS});
725
726  # List of defined macros, add "-D" in front of each macro
727  my @ppkeys  = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{PPKEYS});
728  @ppkeys     = map {($tool{$tool_src_pp{DEFINE}} . $_)} @ppkeys;
729
730  # Add "-I" in front of each include directories
731  @inc        = map {($tool{$tool_src_pp{INCLUDE}} . $_)} @inc;
732
733  push @command, (@ppflags, @ppkeys, @inc, $self->base);
734
735  # Change to container directory of source file
736  my $old_cwd = $self->_chdir($self->dir());
737
738  # Execute the command, getting the output lines
739  my $verbose = $self->verbose;
740  my @outlines = &run_command (
741    \@command, METHOD => 'qx', PRINT => $verbose > 1, TIME => $verbose > 2,
742  );
743
744  # Change back to original directory
745  $self->_chdir($old_cwd);
746
747  return \@outlines;
748}
749
750# ------------------------------------------------------------------------------
751# SYNOPSIS
752#   $rules = %{ $self->get_rules };
753#
754# DESCRIPTION
755#   This method returns a reference to a hash in the following format:
756#     $rules = {
757#       target => {ACTION => action, DEP => [dependencies], ...},
758#       ...    => {...},
759#     };
760#   where the 1st rank keys are the available targets for building this source
761#   file, the second rank keys are ACTION and DEP. The value of ACTION is the
762#   action for building the target, which can be "COMPILE", "LOAD", "TOUCH",
763#   "CP" or "AR". The value of DEP is a refernce to an array containing a list
764#   of dependencies suitable for insertion into the Makefile.
765# ------------------------------------------------------------------------------
766
767sub get_rules {
768  my $self = shift;
769
770  my $rules;
771  my %outfile_ext = %{ $self->setting ('OUTFILE_EXT') };
772
773  if ($self->is_type_all (qw/SOURCE/)) {
774    # Source file
775    # --------------------------------------------------------------------------
776    # Determine whether the language of the source file is supported
777    my %tool_src = %{ $self->setting ('TOOL_SRC') };
778
779    return () unless $self->lang;
780
781    # Compile object
782    # --------------------------------------------------------------------------
783    if ($self->objbase) {
784      # Depends on the source file
785      my @dep = ($self->rule_src);
786
787      # Depends on the compiler flags flags-file
788      my @flags;
789      push @flags, ('FLAGS' )
790        if $self->flagsbase ('FLAGS' );
791      push @flags, ('PPKEYS')
792        if $self->flagsbase ('PPKEYS') and not $self->ppsrc;
793
794      push @dep, $self->flagsbase ($_) for (@flags);
795
796      # Source file dependencies
797      for my $name (sort keys %{ $self->dep }) {
798        # A Fortran 9X module, lower case object file name
799        if ($self->dep ($name) eq 'USE') {
800          (my $root = $name) =~ s/\.\w+$//;
801          push @dep, lc ($root) . $outfile_ext{OBJ};
802
803        # An include file
804        } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
805          push @dep, $name;
806        }
807      }
808
809      $rules->{$self->objbase} = {ACTION => 'COMPILE', DEP => \@dep};
810
811      # Touch flags-files
812      # ------------------------------------------------------------------------
813      for my $flag (@flags) {
814        next unless $self->flagsbase ($flag);
815
816        $rules->{$self->flagsbase ($flag)} = {
817          ACTION => 'TOUCH',
818          DEP    => [
819            $self->flagsbase ($tool_src{$self->lang}{$flag}, -2),
820          ],
821          DEST   => '$(FCM_FLAGSDIR)',
822        };
823      }
824    }
825
826    if ($self->exebase) {
827      # Link into an executable
828      # ------------------------------------------------------------------------
829      my @dep = ();
830      push @dep, $self->objbase               if $self->objbase;
831      push @dep, $self->flagsbase ('LD'     ) if $self->flagsbase ('LD'     );
832      push @dep, $self->flagsbase ('LDFLAGS') if $self->flagsbase ('LDFLAGS');
833
834      # Depends on BLOCKDATA program units, for Fortran programs
835      my %blockdata = %{ $self->setting ('BLD_BLOCKDATA') };
836      my @blkobj    = ();
837
838      if ($self->is_type_any (qw/FPP FORTRAN/) and keys %blockdata) {
839        # List of BLOCKDATA object files
840        if (exists $blockdata{$self->exebase}) {
841          @blkobj = split /\s+/, $blockdata{$self->exebase};
842
843        } elsif (exists $blockdata{''}) {
844          @blkobj = split /\s+/, $blockdata{''};
845        }
846
847        for my $name (@blkobj) {
848          (my $root = $name) =~ s/\.\w+$//;
849          $name = $root . $outfile_ext{OBJ};
850          push @dep, $root . $outfile_ext{DONE};
851        }
852      }
853
854      # Extra executable dependencies
855      my %exe_dep = %{ $self->setting ('BLD_DEP_EXE') };
856      if (keys %exe_dep) {
857        my @exe_deps;
858        if (exists $exe_dep{$self->exebase}) {
859          @exe_deps = split /\s+/, $exe_dep{$self->exebase};
860
861        } elsif (exists $exe_dep{''}) {
862          @exe_deps = $exe_dep{''} ? split (/\s+/, $exe_dep{''}) : ('');
863        }
864
865        my $pattern = '\\' . $outfile_ext{OBJ} . '$';
866
867        for my $name (@exe_deps) {
868          if ($name =~ /$pattern/) {
869            # Extra dependency is an object
870            (my $root = $name) =~ s/\.\w+$//;
871            push @dep, $root . $outfile_ext{DONE};
872
873          } else {
874            # Extra dependency is a sub-package
875            my $var;
876            if ($self->setting ('FCM_PCK_OBJECTS', $name)) {
877              # sub-package name contains unusual characters
878              $var = $self->setting ('FCM_PCK_OBJECTS', $name);
879
880            } else {
881              # sub-package name contains normal characters
882              $var = $name ? join ('__', ('OBJECTS', $name)) : 'OBJECTS';
883            }
884
885            push @dep, '$(' . $var . ')';
886          }
887        }
888      }
889
890      # Source file dependencies
891      for my $name (sort keys %{ $self->dep }) {
892        (my $root = $name) =~ s/\.\w+$//;
893
894        # Lowercase name for object dependency
895        $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
896
897        # Select "done" file extension
898        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
899          push @dep, $name . $outfile_ext{IDONE};
900
901        } else {
902          push @dep, $root . $outfile_ext{DONE};
903        }
904      }
905
906      $rules->{$self->exebase} = {
907        ACTION => 'LOAD', DEP => \@dep, BLOCKDATA => \@blkobj,
908      };
909
910      # Touch Linker flags-file
911      # ------------------------------------------------------------------------
912      for my $flag (qw/LD LDFLAGS/) {
913        $rules->{$self->flagsbase ($flag)} = {
914          ACTION => 'TOUCH',
915          DEP    => [$self->flagsbase ($flag, -2)],
916          DEST   => '$(FCM_FLAGSDIR)',
917        };
918      }
919
920    }
921
922    if ($self->donebase) {
923      # Touch done file
924      # ------------------------------------------------------------------------
925      my @dep = ($self->objbase);
926
927      for my $name (sort keys %{ $self->dep }) {
928        (my $root = $name) =~ s/\.\w+$//;
929
930        # Lowercase name for object dependency
931        $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
932
933        # Select "done" file extension
934        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
935          push @dep, $name . $outfile_ext{IDONE};
936
937        } else {
938          push @dep, $root . $outfile_ext{DONE};
939        }
940      }
941
942      $rules->{$self->donebase} = {
943        ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
944      };
945    }
946   
947    if ($self->interfacebase) {
948      # Interface target
949      # ------------------------------------------------------------------------
950      # Source file dependencies
951      my @dep = ();
952      for my $name (sort keys %{ $self->dep }) {
953        # Depends on Fortran 9X modules
954        push @dep, lc ($name) . $outfile_ext{OBJ}
955          if $self->dep ($name) eq 'USE';
956      }
957
958      $rules->{$self->interfacebase} = {ACTION => '', DEP => \@dep};
959    }
960
961  } elsif ($self->is_type_all ('INCLUDE')) {
962    # Copy include target
963    # --------------------------------------------------------------------------
964    my @dep = ($self->rule_src);
965
966    for my $name (sort keys %{ $self->dep }) {
967      # A Fortran 9X module, lower case object file name
968      if ($self->dep ($name) eq 'USE') {
969        (my $root = $name) =~ s/\.\w+$//;
970        push @dep, lc ($root) . $outfile_ext{OBJ};
971
972      # An include file
973      } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
974        push @dep, $name;
975      }
976    }
977
978    $rules->{$self->curbase} = {
979      ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_INCDIR)',
980    };
981
982    # Touch IDONE file
983    # --------------------------------------------------------------------------
984    if ($self->donebase) {
985      my @dep = ($self->rule_src);
986
987      for my $name (sort keys %{ $self->dep }) {
988        (my $root = $name) =~ s/\.\w+$//;
989
990        # Lowercase name for object dependency
991        $root   = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
992
993        # Select "done" file extension
994        if ($self->dep ($name) =~ /^(?:INC|H)$/) {
995          push @dep, $name . $outfile_ext{IDONE};
996
997        } else {
998          push @dep, $root . $outfile_ext{DONE};
999        }
1000      }
1001
1002      $rules->{$self->donebase} = {
1003        ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
1004      };
1005    }
1006
1007  } elsif ($self->is_type_any (qw/EXE SCRIPT/)) {
1008    # Copy executable file
1009    # --------------------------------------------------------------------------
1010    my @dep = ($self->rule_src);
1011
1012    # Depends on dummy copy file, if file is an "always build type"
1013    push @dep, $self->setting (qw/BLD_CPDUMMY/)
1014      if $self->is_type_any (split (
1015        /$Fcm::Config::DELIMITER_LIST/, $self->setting ('BLD_TYPE_ALWAYS_BUILD')
1016      ));
1017
1018    # Depends on other executable files
1019    for my $name (sort keys %{ $self->dep }) {
1020      push @dep, $name if $self->dep ($name) eq 'EXE';
1021    }
1022
1023    $rules->{$self->curbase} = {
1024      ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_BINDIR)',
1025    };
1026
1027  } elsif (@{ $self->children }) {
1028    # Targets for top level and package flags files and dummy dependencies
1029    # --------------------------------------------------------------------------
1030    my %tool_src   = %{ $self->setting ('TOOL_SRC') };
1031    my %flags_tool = (LD => '', LDFLAGS => '');
1032
1033    for my $key (keys %tool_src) {
1034      $flags_tool{$tool_src{$key}{FLAGS}} = $tool_src{$key}{COMMAND}
1035        if exists $tool_src{$key}{FLAGS};
1036
1037      $flags_tool{$tool_src{$key}{PPKEYS}} = ''
1038        if exists $tool_src{$key}{PPKEYS};
1039    }
1040
1041    for my $name (sort keys %flags_tool) {
1042      my @dep = $self->pkgname eq '' ? () : $self->flagsbase ($name, -2);
1043      push @dep, $self->flagsbase ($flags_tool{$name})
1044        if $self->pkgname eq '' and $flags_tool{$name};
1045
1046      $rules->{$self->flagsbase ($flags_tool{$name})} = {
1047        ACTION => 'TOUCH',
1048        DEST   => '$(FCM_FLAGSDIR)',
1049      } if $self->pkgname eq '' and $flags_tool{$name};
1050
1051      $rules->{$self->flagsbase ($name)} = {
1052        ACTION => 'TOUCH',
1053        DEP    => \@dep,
1054        DEST   => '$(FCM_FLAGSDIR)',
1055      };
1056    }
1057
1058    # Package object and library
1059    # --------------------------------------------------------------------------
1060    {
1061      my @dep;
1062      # Add objects from children
1063      for my $child (sort {$a->pkgname cmp $b->pkgname} @{ $self->children }) {
1064        push @dep, $child->rule_obj_var (1)
1065          if $child->libbase and $child->rules ($child->libbase);
1066        push @dep, $child->objbase
1067          if $child->cursrc and $child->objbase and
1068             not $child->is_type_any (qw/PROGRAM BLOCKDATA/);
1069      }
1070
1071      if (@dep) {
1072        $rules->{$self->libbase} = {ACTION => 'AR', DEP => \@dep};
1073      }
1074    }
1075
1076    # Package data files
1077    # --------------------------------------------------------------------------
1078    {
1079      my @dep;
1080      for my $child (@{ $self->children }) {
1081        push @dep, $child->rule_src if $child->src and not $child->type;
1082      }
1083
1084      if (@dep) {
1085        push @dep, $self->setting (qw/BLD_CPDUMMY/);
1086        $rules->{$self->etcbase} = {
1087          ACTION => 'CP_DATA', DEP => \@dep, DEST => '$(FCM_ETCDIR)',
1088        };
1089      }
1090    }
1091  }
1092
1093  return $rules;
1094}
1095
1096# ------------------------------------------------------------------------------
1097# SYNOPSIS
1098#   $value = $obj->get_setting ($setting[, @prefix]);
1099#
1100# DESCRIPTION
1101#   This method gets the correct $setting for the current source by following
1102#   its package name. If @prefix is set, get the setting with the given prefix.
1103# ------------------------------------------------------------------------------
1104
1105sub get_setting {
1106  my ($self, $setting, @prefix) = @_;
1107
1108  my $val;
1109  for my $name (reverse @{ $self->pkgnames }) {
1110    my @names = split /__/, $name;
1111    $val = $self->setting ($setting, join ('__', (@prefix, @names)));
1112
1113    $val = $self->setting ($setting, join ('__', (@prefix, @names)))
1114      if (not defined $val) and @names and $names[-1] =~ s/\.[^\.]+$//;
1115    last if defined $val;
1116  }
1117
1118  return $val;
1119}
1120
1121# ------------------------------------------------------------------------------
1122# SYNOPSIS
1123#   $type = $self->get_type();
1124#
1125# DESCRIPTION
1126#   This method determines whether the source is a type known to the
1127#   build system. If so, it returns the type flags delimited by "::".
1128# ------------------------------------------------------------------------------
1129
1130sub get_type {
1131  my $self = shift();
1132  my @IGNORE_LIST
1133    = split(/$Fcm::Config::DELIMITER_LIST/, $self->setting('INFILE_IGNORE'));
1134  if (grep {$self->curbase() eq $_} @IGNORE_LIST) {
1135    return q{};
1136  }
1137  # User defined
1138  my $type = $self->setting('BLD_TYPE', $self->pkgname());
1139  # Extension
1140  if (!defined($type)) {
1141    my $ext = $self->curext() ? substr($self->curext(), 1) : q{};
1142    $type = $self->setting('INFILE_EXT', $ext);
1143  }
1144  # Pattern of name
1145  if (!defined($type)) {
1146    my %NAME_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_PAT')};
1147    PATTERN:
1148    while (my ($pattern, $value) = each(%NAME_PATTERN_TO_TYPE_HASH)) {
1149      if ($self->curbase() =~ $pattern) {
1150        $type = $value;
1151        last PATTERN;
1152      }
1153    }
1154  }
1155  # Pattern of #! line
1156  if (!defined($type) && -s $self->cursrc() && -T _) {
1157    my $handle = _open($self->cursrc());
1158    my $line = readline($handle);
1159    close($handle);
1160    my %SHEBANG_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_TXT')};
1161    PATTERN:
1162    while (my ($pattern, $value) = each(%SHEBANG_PATTERN_TO_TYPE_HASH)) {
1163      if ($line =~ qr{^\#!.*$pattern}msx) {
1164        $type = $value;
1165        last PATTERN;
1166      }
1167    }
1168  }
1169  if (!$type) {
1170    return $type;
1171  }
1172  # Extra type information for selected file types
1173  my %EXTRA_FOR = (
1174    qr{\b (?:FORTRAN|FPP) \b}msx => \&_get_type_extra_for_fortran,
1175    qr{\b C \b}msx               => \&_get_type_extra_for_c,
1176  );
1177  EXTRA:
1178  while (my ($key, $code_ref) = each(%EXTRA_FOR)) {
1179    if ($type =~ $key) {
1180      my $handle = _open($self->cursrc());
1181      LINE:
1182      while (my $line = readline($handle)) {
1183        my $extra = $code_ref->($line);
1184        if ($extra) {
1185          $type .= $Fcm::Config::DELIMITER . $extra;
1186          last LINE;
1187        }
1188      }
1189      close($handle);
1190      last EXTRA;
1191    }
1192  }
1193  return $type;
1194}
1195
1196sub _get_type_extra_for_fortran {
1197  my ($match) = $_[0] =~ qr{\A \s* (PROGRAM|MODULE|BLOCK\s*DATA) \b}imsx;
1198  if (!$match) {
1199    return;
1200  }
1201  $match =~ s{\s}{}g;
1202  uc($match)
1203}
1204
1205sub _get_type_extra_for_c {
1206  ($_[0] =~ qr{int\s+main\s*\(}msx) ? 'PROGRAM' : undef;
1207}
1208
1209# ------------------------------------------------------------------------------
1210# SYNOPSIS
1211#   $flag = $obj->is_in_package ($name);
1212#
1213# DESCRIPTION
1214#   This method returns true if current package is in the package $name.
1215# ------------------------------------------------------------------------------
1216
1217sub is_in_package {
1218  my ($self, $name) = @_;
1219 
1220  my $return = 0;
1221  for (@{ $self->pkgnames }) {
1222    next unless /^$name(?:\.\w+)?$/;
1223    $return = 1;
1224    last;
1225  }
1226
1227  return $return;
1228}
1229
1230# ------------------------------------------------------------------------------
1231# SYNOPSIS
1232#   $flag = $obj->is_type_all ($arg, ...);
1233#   $flag = $obj->is_type_any ($arg, ...);
1234#
1235# DESCRIPTION
1236#   This method returns a flag for the following:
1237#     is_type_all - does type match all of the arguments?
1238#     is_type_any - does type match any of the arguments?
1239# ------------------------------------------------------------------------------
1240
1241for my $name ('all', 'any') {
1242  no strict 'refs';
1243
1244  my $subname = 'is_type_' . $name;
1245
1246  *$subname = sub {
1247    my ($self, @intypes) = @_;
1248
1249    my $rc = 0;
1250    if ($self->type) {
1251      my %types = map {($_, 1)} split /$Fcm::Config::DELIMITER/, $self->type;
1252
1253      for my $intype (@intypes) {
1254        $rc = exists $types{$intype};
1255        last if ($name eq 'all' and not $rc) or ($name eq 'any' and $rc);
1256      }
1257    }
1258
1259    return $rc;
1260  }
1261}
1262
1263# ------------------------------------------------------------------------------
1264# SYNOPSIS
1265#   $string = $obj->rule_obj_var ([$read]);
1266#
1267# DESCRIPTION
1268#   This method returns a string containing the make rule object variable for
1269#   the current package. If $read is set, return $($string)
1270# ------------------------------------------------------------------------------
1271
1272sub rule_obj_var {
1273  my ($self, $read) = @_;
1274
1275  my $return;
1276  if ($self->setting ('FCM_PCK_OBJECTS', $self->pkgname)) {
1277    # Package name registered in unusual list
1278    $return = $self->setting ('FCM_PCK_OBJECTS', $self->pkgname);
1279
1280  } else {
1281    # Package name not registered in unusual list
1282    $return = $self->pkgname
1283              ? join ('__', ('OBJECTS', $self->pkgname)) : 'OBJECTS';
1284  }
1285
1286  $return = $read ? '$(' . $return . ')' : $return;
1287
1288  return $return;
1289}
1290
1291# ------------------------------------------------------------------------------
1292# SYNOPSIS
1293#   $string = $obj->rule_src ();
1294#
1295# DESCRIPTION
1296#   This method returns a string containing the location of the source file
1297#   relative to the build root. This string will be suitable for use in a
1298#   "Make" rule file for FCM.
1299# ------------------------------------------------------------------------------
1300
1301sub rule_src {
1302  my $self = shift;
1303
1304  my $return = $self->cursrc;
1305  LABEL: for my $name (qw/SRC PPSRC/) {
1306    for my $i (0 .. @{ $self->setting ('PATH', $name) } - 1) {
1307      my $dir = $self->setting ('PATH', $name)->[$i];
1308      next unless index ($self->cursrc, $dir) == 0;
1309
1310      $return = File::Spec->catfile (
1311        '$(FCM_' . $name . 'DIR' . ($i ? $i : '') . ')',
1312        File::Spec->abs2rel ($self->cursrc, $dir),
1313      );
1314      last LABEL;
1315    }
1316  }
1317
1318  return $return;
1319}
1320
1321# ------------------------------------------------------------------------------
1322# SYNOPSIS
1323#   $rc = $obj->write_lib_dep_excl ();
1324#
1325# DESCRIPTION
1326#   This method writes a set of exclude dependency configurations for the
1327#   library of this package.
1328# ------------------------------------------------------------------------------
1329
1330sub write_lib_dep_excl {
1331  my $self = shift();
1332  if (!find_file_in_path($self->libbase(), $self->setting(qw/PATH LIB/))) {
1333    return 0;
1334  }
1335
1336  my $ETC_DIR = $self->setting(qw/PATH ETC/)->[0];
1337  my $CFG_EXT = $self->setting(qw/OUTFILE_EXT CFG/);
1338  my $LABEL_OF_EXCL_DEP = $self->cfglabel('BLD_DEP_EXCL');
1339  my @SETTINGS = (
1340       #dependency   #source file type list       #dependency name function
1341       ['H'        , [qw{INCLUDE CPP          }], sub {$_[0]->base()}         ],
1342       ['INTERFACE', [qw{INCLUDE INTERFACE    }], sub {$_[0]->base()}         ],
1343       ['INC'      , [qw{INCLUDE              }], sub {$_[0]->base()}         ],
1344       ['USE'      , [qw{SOURCE FORTRAN MODULE}], sub {$_[0]->root()}         ],
1345       ['INTERFACE', [qw{SOURCE FORTRAN       }], sub {$_[0]->interfacebase()}],
1346       ['OBJ'      , [qw{SOURCE               }], sub {$_[0]->root()}         ],
1347  );
1348
1349  my $cfg = Fcm::CfgFile->new();
1350  my @stack = ($self);
1351  NODE:
1352  while (my $node = pop(@stack)) {
1353    # Is a directory
1354    if (@{$node->children()}) {
1355      push(@stack, reverse(@{$node->children()}));
1356      next NODE;
1357    }
1358    # Is a typed file
1359    if (
1360          $node->cursrc()
1361      &&  $node->type()
1362      &&  !$node->is_type_any(qw{PROGRAM BLOCKDATA})
1363    ) {
1364      for (@SETTINGS) {
1365        my ($key, $type_list_ref, $name_func_ref) = @{$_};
1366        my $name = $name_func_ref->($node);
1367        if ($name && $node->is_type_all(@{$type_list_ref})) {
1368          push(
1369            @{$cfg->lines()},
1370            Fcm::CfgLine->new(
1371              label => $LABEL_OF_EXCL_DEP,
1372              value => $key . $Fcm::Config::DELIMITER . $name,
1373            ),
1374          );
1375          next NODE;
1376        }
1377      }
1378    }
1379  }
1380
1381  # Write to configuration file
1382  $cfg->print_cfg(
1383    File::Spec->catfile($ETC_DIR, $self->libbase('lib', $CFG_EXT)),
1384  );
1385}
1386
1387# ------------------------------------------------------------------------------
1388# SYNOPSIS
1389#   $string = $obj->write_rules ();
1390#
1391# DESCRIPTION
1392#   This method returns a string containing the "Make" rules for building the
1393#   source file.
1394# ------------------------------------------------------------------------------
1395
1396sub write_rules {
1397  my $self  = shift;
1398  my $mk    = '';
1399
1400  for my $target (sort keys %{ $self->rules }) {
1401    my $rule = $self->rules ($target);
1402    next unless defined ($rule->{ACTION});
1403
1404    if ($rule->{ACTION} eq 'AR') {
1405      my $var = $self->rule_obj_var;
1406      $mk .= ($var eq 'OBJECTS' ? 'export ' : '') . $var . ' =';
1407      $mk .= ' ' . join (' ', @{ $rule->{DEP} });
1408      $mk .= "\n\n";
1409    }
1410
1411    $mk .= $target . ':';
1412   
1413    if ($rule->{ACTION} eq 'AR') {
1414      $mk .= ' ' . $self->rule_obj_var (1);
1415
1416    } else {
1417      for my $dep (@{ $rule->{DEP} }) {
1418        $mk .= ' ' . $dep;
1419      }
1420    }
1421
1422    $mk .= "\n";
1423
1424    if (exists $rule->{ACTION}) {
1425      if ($rule->{ACTION} eq 'AR') {
1426        $mk .= "\t" . 'fcm_internal archive $@ $^' . "\n";
1427
1428      } elsif ($rule->{ACTION} eq 'CP') {
1429        $mk .= "\t" . 'cp $< ' . $rule->{DEST} . "\n";
1430        $mk .= "\t" . 'chmod u+w ' .
1431               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1432
1433      } elsif ($rule->{ACTION} eq 'CP_DATA') {
1434        $mk .= "\t" . 'cp $^ ' . $rule->{DEST} . "\n";
1435        $mk .= "\t" . 'touch ' .
1436               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1437
1438      } elsif ($rule->{ACTION} eq 'COMPILE') {
1439        if ($self->lang) {
1440          $mk .= "\t" . 'fcm_internal compile:' . substr ($self->lang, 0, 1) .
1441                 ' ' . $self->pkgnames->[-2] . ' $< $@';
1442          $mk .= ' 1' if ($self->flagsbase ('PPKEYS') and not $self->ppsrc);
1443          $mk .= "\n";
1444        }
1445
1446      } elsif ($rule->{ACTION} eq 'LOAD') {
1447        if ($self->lang) {
1448          $mk .= "\t" . 'fcm_internal load:' . substr ($self->lang, 0, 1) .
1449                 ' ' . $self->pkgnames->[-2] . ' $< $@';
1450          $mk .= ' ' . join (' ', @{ $rule->{BLOCKDATA} })
1451            if @{ $rule->{BLOCKDATA} };
1452          $mk .= "\n";
1453        }
1454
1455      } elsif ($rule->{ACTION} eq 'TOUCH') {
1456        $mk .= "\t" . 'touch ' .
1457               File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
1458      }
1459    }
1460
1461    $mk .= "\n";
1462  }
1463
1464  return $mk;
1465}
1466
1467# Wraps "chdir". Returns old directory.
1468sub _chdir {
1469  my ($self, $dir) = @_;
1470  my $old_cwd = cwd();
1471  $self->_event('CHDIR', $dir);
1472  chdir($dir) || croak(sprintf($ERR_MESS_OF{CHDIR}, $dir));
1473  $old_cwd;
1474}
1475
1476# Wraps an event.
1477sub _event {
1478  my ($self, $key, @args) = @_;
1479  my ($format, $level) = @{$EVENT_SETTING_OF{$key}};
1480  $level ||= 1;
1481  if ($self->verbose() >= $level) {
1482    printf($format . ".\n", @args);
1483  }
1484}
1485
1486# Wraps "open".
1487sub _open {
1488  my ($path, $mode) = @_;
1489  $mode ||= '<';
1490  open(my $handle, $mode, $path) || croak(sprintf($ERR_MESS_OF{OPEN}, $path, $!));
1491  $handle;
1492}
1493
1494# ------------------------------------------------------------------------------
1495
14961;
1497
1498__END__
Note: See TracBrowser for help on using the repository browser.