source: vendors/FCM/lib/Fcm/BuildTask.pm @ 14430

Last change on this file since 14430 was 14430, checked in by smasson, 7 months ago

FCM: update Build Task?.pm to avoid circular dependency, ticket:2598#comment:37

  • Property svn:keywords set to Id
File size: 11.3 KB
Line 
1# ------------------------------------------------------------------------------
2# NAME
3#   Fcm::BuildTask
4#
5# DESCRIPTION
6#   This class hosts information of a build task in the FCM build system.
7#
8# COPYRIGHT
9#   (C) Crown copyright Met Office. All rights reserved.
10#   For further details please refer to the file COPYRIGHT.txt
11#   which you should have received as part of this distribution.
12# ------------------------------------------------------------------------------
13
14package Fcm::BuildTask;
15@ISA = qw(Fcm::Base);
16
17# Standard pragma
18use strict;
19use warnings;
20
21# Standard modules
22use Carp;
23use File::Compare;
24use File::Copy;
25use File::Basename;
26use File::Path;
27use File::Spec::Functions;
28
29# FCM component modules
30use Fcm::Base;
31use Fcm::Timer;
32use Fcm::Util;
33
34# List of property methods for this class
35my @scalar_properties = (
36  'actiontype',  # type of action
37  'dependency',  # list of dependencies for this target
38  'srcfile',     # reference to input Fcm::BuildSrc instance
39  'output',      # output file
40  'outputmtime', # output file modification time
41  'target',      # target name for this task
42  'targetpath',  # search path for the target
43);
44
45# ------------------------------------------------------------------------------
46# SYNOPSIS
47#   $obj = Fcm::BuildTask->new (%args);
48#
49# DESCRIPTION
50#   This method constructs a new instance of the Fcm::BuildTask class. See
51#   above for allowed list of properties. (KEYS should be in uppercase.)
52# ------------------------------------------------------------------------------
53
54sub new {
55  my $this  = shift;
56  my %args  = @_;
57  my $class = ref $this || $this;
58
59  my $self = Fcm::Base->new (%args);
60
61  bless $self, $class;
62
63  for my $name (@scalar_properties) {
64    $self->{$name} = exists $args{uc ($name)} ? $args{uc ($name)} : undef;
65  }
66
67  return $self;
68}
69
70# ------------------------------------------------------------------------------
71# SYNOPSIS
72#   $value = $obj->X;
73#   $obj->X ($value);
74#
75# DESCRIPTION
76#   Details of these properties are explained in @scalar_properties.
77# ------------------------------------------------------------------------------
78
79for my $name (@scalar_properties) {
80  no strict 'refs';
81
82  *$name = sub {
83    my $self = shift;
84
85    # Argument specified, set property to specified argument
86    if (@_) {
87      $self->{$name} = $_[0];
88
89      if ($name eq 'output') {
90        $self->{outputmtime} = $_[0] ? (stat $_[0]) [9] : undef;
91      }
92    }
93
94    # Default value for property
95    if (not defined $self->{$name}) {
96      if ($name eq 'dependency' or $name eq 'targetpath') {
97        # Reference to an array
98        $self->{$name} = [];
99      }
100    }
101
102    return $self->{$name};
103  }
104}
105
106# ------------------------------------------------------------------------------
107# SYNOPSIS
108#   $rc = $obj->action (TASKLIST => \%tasklist);
109#
110# DESCRIPTION
111#   This method performs the task action and sets the output accordingly. The
112#   argument TASKLIST must be a reference to a hash containing the other tasks
113#   of the build, which this task may depend on. The keys of the hash must the
114#   name of the target names of the tasks, and the values of the hash must be
115#   the references to the corresponding Fcm::BuildTask instances. The method
116#   returns true if the task has been performed to create a new version of the
117#   target.
118# ------------------------------------------------------------------------------
119
120sub action {
121  my $self     = shift;
122  my %args     = @_;
123  my $tasklist = exists $args{TASKLIST} ? $args{TASKLIST} : {};
124
125  return unless $self->actiontype;
126
127  if ( defined $self->srcfile ) {
128    my $bname = basename($self->srcfile->src) ;
129    for my $depend (@{ $self->dependency }) {
130      if ( $bname eq $depend ) {
131       # Recursion suspected
132       return;
133      }
134    }
135  }
136
137  my $uptodate     = 1;
138  my $dep_uptodate = 1;
139
140  # Check if dependencies are up to date
141  # ----------------------------------------------------------------------------
142  for my $depend (@{ $self->dependency }) {
143    if (exists $tasklist->{$depend}) {
144      if (not $tasklist->{$depend}->output) {
145        # Dependency task output is not set, performs its task action
146        if ($tasklist->{$depend}->action (TASKLIST => $tasklist)) {
147          $uptodate     = 0;
148          $dep_uptodate = 0;
149        }
150      }
151
152    } elsif ($self->verbose > 1) {
153      w_report 'Warning: Task for "', $depend,
154               '" does not exist, may be required by ', $self->target;
155    }
156  }
157
158  # Check if the target exists in the search path
159  # ----------------------------------------------------------------------------
160  if (@{ $self->targetpath }) {
161    my $output = find_file_in_path ($self->target, $self->targetpath);
162    $self->output ($output) if $output;
163  }
164
165  # Target is out of date if it does not exist
166  if ($uptodate) {
167    $uptodate = 0 if not $self->output;
168  }
169
170  # Check if current target is older than its dependencies
171  # ----------------------------------------------------------------------------
172  if ($uptodate) {
173    for my $depend (@{ $self->dependency }) {
174      next unless exists $tasklist->{$depend};
175
176      if ($tasklist->{$depend}->outputmtime > $self->outputmtime) {
177        $uptodate     = 0;
178        $dep_uptodate = 0;
179      }
180    }
181
182    if ($uptodate and ref $self->srcfile) {
183      $uptodate = 0 if $self->srcfile->mtime > $self->outputmtime;
184    }
185  }
186
187  if ($uptodate) {
188    # Current target and its dependencies are up to date
189    # --------------------------------------------------------------------------
190    if ($self->actiontype eq 'PP') {
191      # "done" file up to date, set name of pre-processed source file
192      # ------------------------------------------------------------------------
193      my $base     = $self->srcfile->root . lc ($self->srcfile->ext);
194      my @pknames  = split '__', (@{ $self->srcfile->pkgnames })[-2];
195      my @path     = map {
196        catfile ($_, @pknames);
197      } @{ $self->setting (qw/PATH PPSRC/) };
198      my $oldfile = find_file_in_path ($base, \@path);
199      $self->srcfile->ppsrc ($oldfile);
200    }
201
202  } else {
203    # Perform action is not up to date
204    # --------------------------------------------------------------------------
205    # (For GENINTERFACE and PP, perform action if "done" file not up to date)
206    my $new_output = @{ $self->targetpath }
207                     ? catfile ($self->targetpath->[0], $self->target)
208                     : $self->target;
209
210    # Create destination container directory if necessary
211    my $destdir = dirname $new_output;
212
213    if (not -d $destdir) {
214      print 'Make directory: ', $destdir, "\n" if $self->verbose > 2;
215      mkpath $destdir;
216    }
217
218    # List of actions
219    if ($self->actiontype eq 'UPDATE') {
220      # Action is UPDATE: Update file
221      # ------------------------------------------------------------------------
222      print 'Update: ', $new_output, "\n" if $self->verbose > 2;
223      touch_file $new_output
224        or croak 'Unable to update "', $new_output, '", abort';
225      $self->output ($new_output);
226
227    } elsif ($self->actiontype eq 'COPY') {
228      # Action is COPY: copy file to destination if necessary
229      # ------------------------------------------------------------------------
230      my $copy_required = ($dep_uptodate and $self->output and -r $self->output)
231                          ? compare ($self->output, $self->srcfile->src)
232                          : 1;
233
234      if ($copy_required) {
235        # Set up copy command
236        my $srcfile = $self->srcfile->src;
237        my $destfile = catfile ($destdir, basename($srcfile));
238        print 'Copy: ', $srcfile, "\n", '  to: ', $destfile, "\n"
239          if $self->verbose > 2;
240        &copy ($srcfile, $destfile)
241          or die $srcfile, ': copy to ', $destfile, ' failed (', $!, '), abort';
242        chmod (((stat ($srcfile))[2] & 07777), $destfile);
243
244        $self->output ($new_output);
245
246      } else {
247        $uptodate = 1;
248      }
249
250    } elsif ($self->actiontype eq 'PP' or $self->actiontype eq 'GENINTERFACE') {
251      # Action is PP or GENINTERFACE: process file
252      # ------------------------------------------------------------------------
253      my ($newlines, $base, @path);
254
255      if ($self->actiontype eq 'PP') {
256        # Invoke the pre-processor on the source file
257        # ----------------------------------------------------------------------
258        # Get lines in the pre-processed source
259        $newlines = $self->srcfile->get_pre_process;
260        $base     = $self->srcfile->root . lc ($self->srcfile->ext);
261
262        # Get search path for the existing pre-processed file
263        my @pknames  = split '__', (@{ $self->srcfile->pkgnames })[-2];
264        @path        = map {
265          catfile ($_, @pknames);
266        } @{ $self->setting (qw/PATH PPSRC/) };
267
268      } else { # if ($self->actiontype eq 'GENINTERFACE')
269        # Invoke the interface generator
270        # ----------------------------------------------------------------------
271        # Get new interface lines
272        $newlines = $self->srcfile->get_fortran_interface;
273
274        # Get search path for the existing interface file
275        $base     = $self->srcfile->interfacebase;
276        @path     = @{ $self->setting (qw/PATH INC/) },
277      }
278
279
280      # If pre-processed or interface file exists,
281      # compare its content with new lines to see if it has been updated
282      my $update_required = 1;
283      my $oldfile = find_file_in_path ($base, \@path);
284
285      if ($oldfile and -r $oldfile) {
286        # Read old file
287        open FILE, '<', $oldfile;
288        my @oldlines = readline 'FILE';
289        close FILE;
290
291        # Compare old contents and new contents
292        if (@oldlines eq @$newlines) {
293          $update_required = grep {
294            $oldlines[$_] ne $newlines->[$_];
295          } (0 .. $#oldlines);
296        }
297      }
298
299      if ($update_required) {
300        # Update the pre-processed source or interface file
301        # ----------------------------------------------------------------------
302        # Determine container directory of the  pre-processed or interface file
303        my $newfile = @path ? catfile ($path[0], $base) : $base;
304
305        # Create the container directory if necessary
306        if (not -d $path[0]) {
307          print 'Make directory: ', $path[0], "\n"
308            if $self->verbose > 1;
309          mkpath $path[0];
310        }
311
312        # Update the pre-processor or interface file
313        open FILE, '>', $newfile
314          or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
315        print FILE @$newlines;
316        close FILE
317          or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
318        print 'Generated: ', $newfile, "\n" if $self->verbose > 1;
319
320        # Set the name of the pre-processed file
321        $self->srcfile->ppsrc ($newfile) if $self->actiontype eq 'PP';
322
323      } else {
324        # Content in pre-processed source or interface file is up to date
325        # ----------------------------------------------------------------------
326        $uptodate = 1;
327
328        # Set the name of the pre-processed file
329        $self->srcfile->ppsrc ($oldfile) if $self->actiontype eq 'PP';
330      }
331
332      # Update the "done" file
333      print 'Update: ', $new_output, "\n" if $self->verbose > 2;
334      touch_file $new_output
335        or croak 'Unable to update "', $new_output, '", abort';
336      $self->output ($new_output);
337
338    } else {
339      carp 'Action type "', $self->actiontype, "' not supported";
340    }
341  }
342
343  return not $uptodate;
344}
345
346# ------------------------------------------------------------------------------
347
3481;
349
350__END__
Note: See TracBrowser for help on using the repository browser.