source: PATCHED/FCM_V1.1/lib/Fcm/SrcFile.pm @ 5

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

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