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

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

Remove svn keywords

File size: 11.1 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  my $uptodate     = 1;
128  my $dep_uptodate = 1;
129
130  # Check if dependencies are up to date
131  # ----------------------------------------------------------------------------
132  for my $depend (@{ $self->dependency }) {
133    if (exists $tasklist->{$depend}) {
134      if (not $tasklist->{$depend}->output) {
135        # Dependency task output is not set, performs its task action
136        if ($tasklist->{$depend}->action (TASKLIST => $tasklist)) {
137          $uptodate     = 0;
138          $dep_uptodate = 0;
139        }
140      }
141
142    } elsif ($self->verbose > 1) {
143      w_report 'Warning: Task for "', $depend,
144               '" does not exist, may be required by ', $self->target;
145    }
146  }
147
148  # Check if the target exists in the search path
149  # ----------------------------------------------------------------------------
150  if (@{ $self->targetpath }) {
151    my $output = find_file_in_path ($self->target, $self->targetpath);
152    $self->output ($output) if $output;
153  }
154
155  # Target is out of date if it does not exist
156  if ($uptodate) {
157    $uptodate = 0 if not $self->output;
158  }
159
160  # Check if current target is older than its dependencies
161  # ----------------------------------------------------------------------------
162  if ($uptodate) {
163    for my $depend (@{ $self->dependency }) {
164      next unless exists $tasklist->{$depend};
165
166      if ($tasklist->{$depend}->outputmtime > $self->outputmtime) {
167        $uptodate     = 0;
168        $dep_uptodate = 0;
169      }
170    }
171
172    if ($uptodate and ref $self->srcfile) {
173      $uptodate = 0 if $self->srcfile->mtime > $self->outputmtime;
174    }
175  }
176
177  if ($uptodate) {
178    # Current target and its dependencies are up to date
179    # --------------------------------------------------------------------------
180    if ($self->actiontype eq 'PP') {
181      # "done" file up to date, set name of pre-processed source file
182      # ------------------------------------------------------------------------
183      my $base     = $self->srcfile->root . lc ($self->srcfile->ext);
184      my @pknames  = split '__', (@{ $self->srcfile->pkgnames })[-2];
185      my @path     = map {
186        catfile ($_, @pknames);
187      } @{ $self->setting (qw/PATH PPSRC/) };
188      my $oldfile = find_file_in_path ($base, \@path);
189      $self->srcfile->ppsrc ($oldfile);
190    }
191
192  } else {
193    # Perform action is not up to date
194    # --------------------------------------------------------------------------
195    # (For GENINTERFACE and PP, perform action if "done" file not up to date)
196    my $new_output = @{ $self->targetpath }
197                     ? catfile ($self->targetpath->[0], $self->target)
198                     : $self->target;
199
200    # Create destination container directory if necessary
201    my $destdir = dirname $new_output;
202
203    if (not -d $destdir) {
204      print 'Make directory: ', $destdir, "\n" if $self->verbose > 2;
205      mkpath $destdir;
206    }
207
208    # List of actions
209    if ($self->actiontype eq 'UPDATE') {
210      # Action is UPDATE: Update file
211      # ------------------------------------------------------------------------
212      print 'Update: ', $new_output, "\n" if $self->verbose > 2;
213      touch_file $new_output
214        or croak 'Unable to update "', $new_output, '", abort';
215      $self->output ($new_output);
216
217    } elsif ($self->actiontype eq 'COPY') {
218      # Action is COPY: copy file to destination if necessary
219      # ------------------------------------------------------------------------
220      my $copy_required = ($dep_uptodate and $self->output and -r $self->output)
221                          ? compare ($self->output, $self->srcfile->src)
222                          : 1;
223
224      if ($copy_required) {
225        # Set up copy command
226        my $srcfile = $self->srcfile->src;
227        my $destfile = catfile ($destdir, basename($srcfile));
228        print 'Copy: ', $srcfile, "\n", '  to: ', $destfile, "\n"
229          if $self->verbose > 2;
230        &copy ($srcfile, $destfile)
231          or die $srcfile, ': copy to ', $destfile, ' failed (', $!, '), abort';
232        chmod (((stat ($srcfile))[2] & 07777), $destfile);
233
234        $self->output ($new_output);
235
236      } else {
237        $uptodate = 1;
238      }
239
240    } elsif ($self->actiontype eq 'PP' or $self->actiontype eq 'GENINTERFACE') {
241      # Action is PP or GENINTERFACE: process file
242      # ------------------------------------------------------------------------
243      my ($newlines, $base, @path);
244
245      if ($self->actiontype eq 'PP') {
246        # Invoke the pre-processor on the source file
247        # ----------------------------------------------------------------------
248        # Get lines in the pre-processed source
249        $newlines = $self->srcfile->get_pre_process;
250        $base     = $self->srcfile->root . lc ($self->srcfile->ext);
251
252        # Get search path for the existing pre-processed file
253        my @pknames  = split '__', (@{ $self->srcfile->pkgnames })[-2];
254        @path        = map {
255          catfile ($_, @pknames);
256        } @{ $self->setting (qw/PATH PPSRC/) };
257
258      } else { # if ($self->actiontype eq 'GENINTERFACE')
259        # Invoke the interface generator
260        # ----------------------------------------------------------------------
261        # Get new interface lines
262        $newlines = $self->srcfile->get_fortran_interface;
263
264        # Get search path for the existing interface file
265        $base     = $self->srcfile->interfacebase;
266        @path     = @{ $self->setting (qw/PATH INC/) },
267      }
268
269
270      # If pre-processed or interface file exists,
271      # compare its content with new lines to see if it has been updated
272      my $update_required = 1;
273      my $oldfile = find_file_in_path ($base, \@path);
274
275      if ($oldfile and -r $oldfile) {
276        # Read old file
277        open FILE, '<', $oldfile;
278        my @oldlines = readline 'FILE';
279        close FILE;
280
281        # Compare old contents and new contents
282        if (@oldlines eq @$newlines) {
283          $update_required = grep {
284            $oldlines[$_] ne $newlines->[$_];
285          } (0 .. $#oldlines);
286        }
287      }
288
289      if ($update_required) {
290        # Update the pre-processed source or interface file
291        # ----------------------------------------------------------------------
292        # Determine container directory of the  pre-processed or interface file
293        my $newfile = @path ? catfile ($path[0], $base) : $base;
294
295        # Create the container directory if necessary
296        if (not -d $path[0]) {
297          print 'Make directory: ', $path[0], "\n"
298            if $self->verbose > 1;
299          mkpath $path[0];
300        }
301
302        # Update the pre-processor or interface file
303        open FILE, '>', $newfile
304          or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
305        print FILE @$newlines;
306        close FILE
307          or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
308        print 'Generated: ', $newfile, "\n" if $self->verbose > 1;
309
310        # Set the name of the pre-processed file
311        $self->srcfile->ppsrc ($newfile) if $self->actiontype eq 'PP';
312
313      } else {
314        # Content in pre-processed source or interface file is up to date
315        # ----------------------------------------------------------------------
316        $uptodate = 1;
317
318        # Set the name of the pre-processed file
319        $self->srcfile->ppsrc ($oldfile) if $self->actiontype eq 'PP';
320      }
321
322      # Update the "done" file
323      print 'Update: ', $new_output, "\n" if $self->verbose > 2;
324      touch_file $new_output
325        or croak 'Unable to update "', $new_output, '", abort';
326      $self->output ($new_output);
327
328    } else {
329      carp 'Action type "', $self->actiontype, "' not supported";
330    }
331  }
332
333  return not $uptodate;
334}
335
336# ------------------------------------------------------------------------------
337
3381;
339
340__END__
Note: See TracBrowser for help on using the repository browser.