source: OFFICIAL/FCM_V1.3/lib/Fcm/BuildTask.pm

Last change on this file was 1, checked in by fcm, 15 years ago

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