source: PATCHED/FCM_V1.2/lib/Fcm/SrcFile.pm @ 3

Last change on this file since 3 was 3, checked in by ymipsl, 15 years ago

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