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 | |
---|
16 | package Fcm::SrcFile; |
---|
17 | |
---|
18 | # Standard pragma |
---|
19 | |
---|
20 | use strict; |
---|
21 | use warnings; |
---|
22 | |
---|
23 | # Standard modules |
---|
24 | use Cwd; |
---|
25 | use Carp; |
---|
26 | use File::Basename; |
---|
27 | use File::Spec; |
---|
28 | use File::Spec::Functions; |
---|
29 | |
---|
30 | # FCM component modules |
---|
31 | use Fcm::Util; |
---|
32 | use Fcm::Timer; |
---|
33 | |
---|
34 | # Other modules |
---|
35 | use 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 | |
---|
64 | sub 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 | |
---|
95 | sub 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 | |
---|
112 | sub 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 | |
---|
132 | sub 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 | |
---|
153 | sub 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 | |
---|
173 | sub 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 | |
---|
187 | sub 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 | |
---|
201 | sub 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 | |
---|
215 | sub 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 | |
---|
233 | sub 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 | |
---|
249 | sub 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 | |
---|
263 | sub 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 | |
---|
277 | sub 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 | |
---|
291 | sub 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 | |
---|
307 | sub 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 | |
---|
326 | sub 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 | |
---|
353 | sub 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 | |
---|
382 | sub 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 | |
---|
404 | sub 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 | |
---|
437 | sub 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 | |
---|
458 | sub 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 | |
---|
476 | sub 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 | |
---|
501 | sub 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 | |
---|
529 | sub 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 | |
---|
548 | sub 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 | |
---|
572 | sub 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 | |
---|
650 | sub 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 | |
---|
705 | sub 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 | |
---|
802 | sub 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 | |
---|
834 | sub 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 | |
---|
995 | sub 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 | |
---|
1052 | sub _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 | |
---|
1109 | sub _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 | |
---|
1216 | sub _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 | |
---|
1249 | sub _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 | |
---|
1331 | sub _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 | |
---|
1391 | sub _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 $@ $^' . "\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 | |
---|
1433 | sub _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 | |
---|
1477 | 1; |
---|
1478 | |
---|
1479 | __END__ |
---|