source: LMDZ5/branches/testing/tools/fcm/lib/Fcm/BuildTask.pm @ 5371

Last change on this file since 5371 was 1665, checked in by Laurent Fairhead, 12 years ago

Version testing basée sur la r1628

http://lmdz.lmd.jussieu.fr/utilisateurs/distribution-du-modele/versions-intermediaires

Testing release based on r1628
File size: 13.0 KB
RevLine 
[1578]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
17# Standard pragma
18use strict;
19use warnings;
20
21# Standard modules
22use Carp;
23use File::Compare;
24use File::Basename;
25use File::Path;
26use File::Spec::Functions;
27
28# FCM component modules
29use Fcm::Util;
30use Fcm::Timer;
31
32# ------------------------------------------------------------------------------
33# SYNOPSIS
34#   $task = Fcm::BuildTask->new (
35#     CONFIG     => $config,
36#     TARGET     => $target,
37#     TARGETPATH => \@targetpath,
38#     SRCFILE    => $srcfile,
39#     DEPENDENCY => \@dependency,
40#     TASKTYPE   => $tasktype,
41#   );
42#
43# DESCRIPTION
44#   This method constructs a new instance of the Fcm::BuildTask class.
45#
46# ARGUMENTS
47#   CONFIG     - reference to a Fcm::Config instance
48#   TARGET     - target name for this task
49#   TARGETPATH - search path for the target
50#   SRCFILE    - reference to input Fcm::SrcFile instance
51#   DEPENDENCY - list of dependencies for this target
52#   TASKTYPE   - type of task to build the target
53# ------------------------------------------------------------------------------
54
55sub new {
56  my $this  = shift;
57  my %args  = @_;
58  my $class = ref $this || $this;
59
60  my $self  = {
61    CONFIG      => exists $args{CONFIG}     ? $args{CONFIG}     : &main::cfg,
62    TARGET      => exists $args{TARGET}     ? $args{TARGET}     : undef,
63    TARGETPATH  => exists $args{TARGETPATH} ? $args{TARGETPATH} : [],
64    SRCFILE     => exists $args{SRCFILE}    ? $args{SRCFILE}    : undef,
65    DEPENDENCY  => exists $args{DEPENDENCY} ? $args{DEPENDENCY} : [],
66    ACTIONTYPE  => exists $args{ACTIONTYPE} ? $args{ACTIONTYPE} : undef,
67
68    OUTPUT      => undef,
69    OUTPUTMTIME => undef,
70  };
71
72  bless $self, $class;
73  return $self;
74}
75
76# ------------------------------------------------------------------------------
77# SYNOPSIS
78#   $config = $task->config;
79#
80# DESCRIPTION
81#   This method returns a reference to the Fcm::Config instance.
82# ------------------------------------------------------------------------------
83
84sub config {
85  my $self = shift;
86
87  return $self->{CONFIG};
88}
89
90# ------------------------------------------------------------------------------
91# SYNOPSIS
92#   $srcfile = $task->srcfile;
93#   $task->srcfile ($srcfile);
94#
95# DESCRIPTION
96#   This method returns the reference to the input Fcm::SrcFile instance
97#   associated with this task. If an argument is specified, the reference is
98#   modified to the value given by the argument.
99# ------------------------------------------------------------------------------
100
101sub srcfile {
102  my $self = shift;
103
104  if (@_) {
105    $self->{SRCFILE} = $_[0];
106  }
107
108  return $self->{SRCFILE};
109}
110
111# ------------------------------------------------------------------------------
112# SYNOPSIS
113#   $actiontype = $task->actiontype;
114#   $task->actiontype ($actiontype);
115#
116# DESCRIPTION
117#   This method returns the action type of this task. If an argument is
118#   specified, the action type of this task is set to the value of the
119#   argument.
120# ------------------------------------------------------------------------------
121
122sub actiontype {
123  my $self = shift;
124
125  if (@_) {
126    $self->{ACTIONTYPE} = $_[0];
127  }
128
129  return $self->{ACTIONTYPE};
130}
131
132# ------------------------------------------------------------------------------
133# SYNOPSIS
134#   $output = $task->output;
135#   $task->output ($output);
136#
137# DESCRIPTION
138#   This method returns the name of the output file after the task has been
139#   performed successfully. If an argument is specified, it sets the output
140#   file (and its last modified time) to the value of the argument.
141# ------------------------------------------------------------------------------
142
143sub output {
144  my $self = shift;
145
146  if (@_) {
147    $self->{OUTPUT}      = $_[0];
148    $self->{OUTPUTMTIME} = (stat $self->{OUTPUT}) [9];
149  }
150
151  return $self->{OUTPUT};
152}
153
154# ------------------------------------------------------------------------------
155# SYNOPSIS
156#   $time = $task->outputmtime;
157#
158# DESCRIPTION
159#   This method returns the modified time of the output file.
160# ------------------------------------------------------------------------------
161
162sub outputmtime {
163  my $self = shift;
164
165  return $self->{OUTPUTMTIME};
166}
167
168# ------------------------------------------------------------------------------
169# SYNOPSIS
170#   $rc = $task->action (TASKLIST => \%tasklist);
171#
172# DESCRIPTION
173#   This method performs the task action and sets the output accordingly. The
174#   argument TASKLIST must be a reference to a hash containing the other tasks
175#   of the build, which this task may depend on. The keys of the hash must the
176#   name of the target names of the tasks, and the values of the hash must be
177#   the references to the corresponding Fcm::BuildTask instances. The method
178#   returns true if the task has been performed to create a new version of the
179#   target.
180# ------------------------------------------------------------------------------
181
182sub action {
183  my $self     = shift;
184  my %args     = @_;
185  my $tasklist = exists $args{TASKLIST} ? $args{TASKLIST} : {};
186
187  return unless $self->actiontype;
188
189  my $uptodate     = 1;
190  my $dep_uptodate = 1;
191
192  # Check if dependencies are up to date
193  # ----------------------------------------------------------------------------
194  for my $depend (@{ $self->{DEPENDENCY} }) {
195    if (exists $tasklist->{$depend}) {
196      if (not $tasklist->{$depend}->output) {
197        # Dependency task output is not set, performs its task action
198        if ($tasklist->{$depend}->action (TASKLIST => $tasklist)) {
199          $uptodate     = 0;
200          $dep_uptodate = 0;
201        }
202      }
203
204    } elsif ($self->config->verbose > 1) {
205      w_report 'Warning: Task for "', $depend,
206               '" does not exist, may be required by ', $self->{TARGET};
207    }
208  }
209
210  # Check if the target exists in the search path
211  # ----------------------------------------------------------------------------
212  if (@{ $self->{TARGETPATH} }) {
213    my $output = find_file_in_path ($self->{TARGET}, $self->{TARGETPATH});
214    $self->output ($output) if $output;
215  }
216
217  # Target is out of date if it does not exist
218  if ($uptodate) {
219    $uptodate = 0 if not $self->output;
220  }
221
222  # Check if current target is older than its dependencies
223  # ----------------------------------------------------------------------------
224  if ($uptodate) {
225    for my $depend (@{ $self->{DEPENDENCY} }) {
226      next unless exists $tasklist->{$depend};
227
228      if ($tasklist->{$depend}->outputmtime > $self->outputmtime) {
229        $uptodate     = 0;
230        $dep_uptodate = 0;
231      }
232    }
233
234    if ($uptodate and ref $self->srcfile) {
235      $uptodate = 0 if $self->srcfile->mtime > $self->outputmtime;
236    }
237  }
238
239  if ($uptodate) {
240    # Current target and its dependencies are up to date
241    # --------------------------------------------------------------------------
242    if ($self->actiontype eq 'PP') {
243      # "done" file up to date, set name of pre-processed source file
244      # ------------------------------------------------------------------------
245      my $base     = $self->srcfile->root . lc ($self->srcfile->ext);
246      my @pck_list = $self->srcfile->get_package_list;
247      pop @pck_list;
248      my @pknames  = split '__', pop (@pck_list);
249      my @path     = map {
250        catfile ($_, @pknames);
251      } @{ $self->config->setting (qw/PATH PPSRC/) };
252      my $oldfile = find_file_in_path ($base, \@path);
253      $self->srcfile->ppsrc ($oldfile);
254    }
255
256  } else {
257    # Perform action is not up to date
258    # --------------------------------------------------------------------------
259    # (For GENINTERFACE and PP, perform action if "done" file not up to date)
260    my $new_output = @{ $self->{TARGETPATH} }
261                     ? catfile ($self->{TARGETPATH}[0], $self->{TARGET})
262                     : $self->{TARGET};
263
264    # Create destination container directory if necessary
265    my $destdir = dirname $new_output;
266
267    if (not -d $destdir) {
268      print 'Make directory: ', $destdir, "\n" if $self->config->verbose > 2;
269      mkpath $destdir;
270    }
271
272    # List of actions
273    if ($self->actiontype eq 'UPDATE') {
274      # Action is UPDATE: Update file
275      # ------------------------------------------------------------------------
276      print 'Update: ', $new_output, "\n" if $self->config->verbose > 2;
277      touch_file $new_output
278        or croak 'Unable to update "', $new_output, '", abort';
279      $self->output ($new_output);
280
281    } elsif ($self->actiontype eq 'COPY') {
282      # Action is COPY: copy file to destination if necessary
283      # ------------------------------------------------------------------------
284      my $copy_required = ($dep_uptodate and $self->output and -r $self->output)
285                          ? compare ($self->output, $self->srcfile->src)
286                          : 1;
287
288      if ($copy_required) {
289        # Set up copy command
290        &run_command (
291          ['cp', $self->srcfile->src, $destdir],
292          TIME => $self->config->verbose > 2,
293        );
294
295        $self->output ($new_output);
296
297      } else {
298        $uptodate = 1;
299      }
300
301    } elsif ($self->actiontype eq 'PP' or $self->actiontype eq 'GENINTERFACE') {
302      # Action is PP or GENINTERFACE: process file
303      # ------------------------------------------------------------------------
304      my ($newlines, $base, @path);
305
306      if ($self->actiontype eq 'PP') {
307        # Invoke the pre-processor on the source file
308        # ----------------------------------------------------------------------
309        # Get lines in the pre-processed source
310        $newlines = $self->srcfile->pre_process;
311        $base     = $self->srcfile->root . lc ($self->srcfile->ext);
312
313        # Get search path for the existing pre-processed file
314        my @pck_list = $self->srcfile->get_package_list;
315        pop @pck_list;
316        my @pknames  = split '__', pop (@pck_list);
317        @path        = map {
318          catfile ($_, @pknames);
319        } @{ $self->config->setting (qw/PATH PPSRC/) };
320
321      } else { # if ($self->actiontype eq 'GENINTERFACE')
322        # Invoke the interface generator
323        # ----------------------------------------------------------------------
324        # Get new interface lines
325        $newlines = $self->srcfile->gen_interface;
326
327        # Get search path for the existing interface file
328        $base     = $self->srcfile->interfacebase;
329        @path     = @{ $self->config->setting (qw/PATH INC/) },
330      }
331
332
333      # If pre-processed or interface file exists,
334      # compare its content with new lines to see if it has been updated
335      my $update_required = 1;
336      my $oldfile = find_file_in_path ($base, \@path);
337
338      if ($oldfile and -r $oldfile) {
339        # Read old file
340        open FILE, '<', $oldfile;
341        my @oldlines = readline 'FILE';
342        close FILE;
343
344        # Compare old contents and new contents
345        if (@oldlines eq @$newlines) {
346          $update_required = grep {
347            $oldlines[$_] ne $newlines->[$_];
348          } (0 .. $#oldlines);
349        }
350      }
351
352      if ($update_required) {
353        # Update the pre-processed source or interface file
354        # ----------------------------------------------------------------------
355        # Determine container directory of the  pre-processed or interface file
356        my $newfile = @path ? catfile ($path[0], $base) : $base;
357
358        # Create the container directory if necessary
359        if (not -d $path[0]) {
360          print 'Make directory: ', $path[0], "\n"
361            if $self->config->verbose > 1;
362          mkpath $path[0];
363        }
364
365        # Update the pre-processor or interface file
366        open FILE, '>', $newfile
367          or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
368        print FILE @$newlines;
369        close FILE
370          or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
371        print 'Generated: ', $newfile, "\n" if $self->config->verbose > 1;
372
373        # Set the name of the pre-processed file
374        $self->srcfile->ppsrc ($newfile) if $self->actiontype eq 'PP';
375
376        # Set the "current" flag of the container source package to "true"
377        $self->srcfile->srcpackage->current (1);
378
379      } else {
380        # Content in pre-processed source or interface file is up to date
381        # ----------------------------------------------------------------------
382        $uptodate = 1;
383
384        # Set the name of the pre-processed file
385        $self->srcfile->ppsrc ($oldfile) if $self->actiontype eq 'PP';
386      }
387
388      # Update the "done" file
389      print 'Update: ', $new_output, "\n" if $self->config->verbose > 2;
390      touch_file $new_output
391        or croak 'Unable to update "', $new_output, '", abort';
392      $self->output ($new_output);
393
394    } else {
395      carp 'Action type "', $self->actiontype, "' not supported";
396    }
397  }
398
399  return not $uptodate;
400}
401
402# ------------------------------------------------------------------------------
403
4041;
405
406__END__
Note: See TracBrowser for help on using the repository browser.