source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM1/BuildTask.pm

Last change on this file was 5129, checked in by abarral, 4 months ago

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