New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
ExtractFile.pm in branches/UKMO/dev_5518_tide_analysis_restart/NEMOGCM/EXTERNAL/fcm/lib/Fcm – NEMO

source: branches/UKMO/dev_5518_tide_analysis_restart/NEMOGCM/EXTERNAL/fcm/lib/Fcm/ExtractFile.pm @ 6061

Last change on this file since 6061 was 6061, checked in by deazer, 8 years ago

Removed SVN Keywords

File size: 11.7 KB
Line 
1# ------------------------------------------------------------------------------
2# NAME
3#   Fcm::ExtractFile
4#
5# DESCRIPTION
6#   Select/combine a file in different branches and extract it to destination.
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
14use warnings;
15use strict;
16
17package Fcm::ExtractFile;
18use base qw{Fcm::Base};
19
20use Fcm::Util      qw{run_command w_report};
21use File::Basename qw{dirname};
22use File::Compare  qw{compare};
23use File::Copy     qw{copy};
24use File::Path     qw{mkpath};
25use File::Spec;
26use File::Temp     qw(tempfile);
27
28# List of property methods for this class
29my @scalar_properties = (
30  'conflict',    # conflict mode
31  'dest',        # search path to destination file
32  'dest_status', # destination status, see below
33  'pkgname',     # package name of this file
34  'src',         # list of Fcm::ExtractSrc, specified for this file
35  'src_actual',  # list of Fcm::ExtractSrc, actually used by this file
36  'src_status',  # source status, see below
37);
38
39# Status code definition for $self->dest_status
40our %DEST_STATUS_CODE = (
41  ''  => 'unchanged',
42  'M' => 'modified',
43  'A' => 'added',
44  'a' => 'added, overridding inherited',
45  'D' => 'deleted',
46  'd' => 'deleted, overridding inherited',
47  '?' => 'irrelevant',
48);
49
50# Status code definition for $self->src_status
51our %SRC_STATUS_CODE = (
52  'A' => 'added by a branch',
53  'B' => 'from the base',
54  'D' => 'deleted by a branch',
55  'M' => 'modified by a branch',
56  'G' => 'merged from 2+ branches',
57  'O' => 'overridden by a branch',
58  '?' => 'irrelevant',
59);
60
61# ------------------------------------------------------------------------------
62# SYNOPSIS
63#   $obj = Fcm::ExtractFile->new ();
64#
65# DESCRIPTION
66#   This method constructs a new instance of the Fcm::ExtractFile class.
67# ------------------------------------------------------------------------------
68
69sub new {
70  my $this  = shift;
71  my %args  = @_;
72  my $class = ref $this || $this;
73
74  my $self = Fcm::Base->new (%args);
75
76  for (@scalar_properties) {
77    $self->{$_} = exists $args{$_} ? $args{$_} : undef;
78  }
79
80  bless $self, $class;
81  return $self;
82}
83
84# ------------------------------------------------------------------------------
85# SYNOPSIS
86#   $value = $obj->X;
87#   $obj->X ($value);
88#
89# DESCRIPTION
90#   Details of these properties are explained in @scalar_properties.
91# ------------------------------------------------------------------------------
92
93for my $name (@scalar_properties) {
94  no strict 'refs';
95
96  *$name = sub {
97    my $self = shift;
98
99    # Argument specified, set property to specified argument
100    if (@_) {
101      $self->{$name} = $_[0];
102    }
103
104    # Default value for property
105    if (not defined $self->{$name}) {
106      if ($name eq 'conflict') {
107        $self->{$name} = 'merge'; # default to "merge" mode
108
109      } elsif ($name eq 'dest' or $name eq 'src' or $name eq 'src_actual') {
110        $self->{$name} = [];      # default to an empty list
111      }
112    }
113
114    return $self->{$name};
115  }
116}
117
118# ------------------------------------------------------------------------------
119# SYNOPSIS
120#   $rc = $obj->run();
121#
122# DESCRIPTION
123#   This method runs only if $self->dest_status is not defined. It updates the
124#   destination according to the source in the list and the conflict mode
125#   setting. It updates the file in $self->dest as appropriate and sets
126#   $self->dest_status. (See above.) This method returns true on success.
127# ------------------------------------------------------------------------------
128
129sub run {
130  my ($self) = @_;
131  my $rc = 1;
132
133  if (not defined ($self->dest_status)) {
134    # Assume file unchanged
135    $self->dest_status ('');
136
137    if (@{ $self->src }) {
138      my $used;
139      # Determine or set up a file for comparing with the destination
140      ($rc, $used) = $self->run_get_used();
141
142      # Attempt to compare the destination with $used. Update on change.
143      if ($rc) {
144        $rc = defined ($used) ? $self->run_update($used) : $self->run_delete();
145      }
146
147    } else {
148      # No source, delete file in destination
149      $self->src_status ('?');
150      $rc = $self->run_delete();
151    }
152  }
153
154  return $rc;
155}
156
157# ------------------------------------------------------------------------------
158# SYNOPSIS
159#   $rc = $obj->run_delete();
160#
161# DESCRIPTION
162#   This method is part of run(). It detects this file in the destination path.
163#   If this file is in the current destination, it attempts to delete it and
164#   sets the dest_status to "D". If this file is in an inherited destination,
165#   it sets the dest_status to "d".
166# ------------------------------------------------------------------------------
167
168sub run_delete {
169  my ($self) = @_;
170
171  my $rc = 1;
172
173  $self->dest_status ('?');
174  for my $i (0 .. @{ $self->dest } - 1) {
175    my $dest = File::Spec->catfile ($self->dest->[$i], $self->pkgname);
176    next unless -f $dest;
177    if ($i == 0) {
178      $rc = unlink $dest;
179      $self->dest_status ('D');
180
181    } else {
182      $self->dest_status ('d');
183      last;
184    }
185  }
186
187  return $rc;
188}
189
190# ------------------------------------------------------------------------------
191# SYNOPSIS
192#   ($rc, $used) = $obj->run_get_used();
193#
194# DESCRIPTION
195#   This method is part of run(). It attempts to work out or set up the $used
196#   file. ($used is undef if it is not defined in a branch for this file.)
197# ------------------------------------------------------------------------------
198
199sub run_get_used {
200  my ($self) = @_;
201  my $rc = 1;
202  my $used;
203
204  my @sources = ($self->src->[0]);
205  my $src_status = 'B';
206  if (defined ($self->src->[0]->cache)) {
207    # File exists in base branch
208    for my $i (1 .. @{ $self->src } - 1) {
209      if (defined ($self->src->[$i]->cache)) {
210        # Detect changes in this file between base branch and branch $i
211        push @sources, $self->src->[$i]
212          if &compare ($self->src->[0]->cache, $self->src->[$i]->cache);
213
214      } else {
215        # File deleted in branch $i
216        @sources = ($self->src->[$i]);
217        last unless $self->conflict eq 'override';
218      }
219    }
220
221    if ($rc) {
222      if (@sources > 2) {
223        if ($self->conflict eq 'fail') {
224          # On conflict, fail in fail mode
225          w_report 'ERROR: ', $self->pkgname,
226                   ': modified in 2+ branches in fail conflict mode.';
227          $rc = undef;
228
229        } elsif ($self->conflict eq 'override') {
230          $used = $sources[-1]->cache;
231          $src_status = 'O';
232
233        } else {
234          # On conflict, attempt to merge in merge mode
235          ($rc, $used) = $self->run_get_used_by_merge (@sources);
236          $src_status = 'G' if $rc;
237        }
238
239      } else {
240        # 0 or 1 change, use last source
241        if (defined $sources[-1]->cache) {
242          $used = $sources[-1]->cache;
243          $src_status = 'M' if @sources > 1;
244
245        } else {
246          $src_status = 'D';
247        }
248      }
249    }
250
251  } else {
252    # File does not exist in base branch
253    @sources = ($self->src->[-1]);
254    $used = $self->src->[1]->cache;
255    $src_status = (defined ($used) ? 'A' : 'D');
256    if ($self->conflict ne 'override' and defined ($used)) {
257      for my $i (1 - @{ $self->src } .. -2) {
258        # Allow this only if files are the same in all branches
259        my $file = $self->src->[$i]->cache;
260        if ((not defined ($file)) or &compare ($used, $file)) {
261          w_report 'ERROR: ', $self->pkgname, ': cannot merge:',
262                   ' not found in base branch,',
263                   ' but differs in subsequent branches.';
264          $rc = undef;
265          last;
266
267        } else {
268          unshift @sources, $self->src->[$i];
269        }
270      }
271    }
272  }
273
274  $self->src_status ($src_status);
275  $self->src_actual (\@sources);
276
277  return ($rc, $used);
278}
279
280# ------------------------------------------------------------------------------
281# SYNOPSIS
282#   ($rc, $used) = $obj->run_get_used_by_merge(@soruces);
283#
284# DESCRIPTION
285#   This method is part of run_get_used(). It attempts to merge the files in
286#   @sources and return a temporary file $used. @sources should be an array of
287#   Fcm::ExtractSrc objects. On success, $rc will be set to true.
288# ------------------------------------------------------------------------------
289
290sub run_get_used_by_merge {
291  my ($self, @sources) = @_;
292  my $rc = 1;
293
294  # Get temporary file
295  my ($fh, $used) = &tempfile ('fcm.ext.merge.XXXXXX', UNLINK => 1);
296  close $fh or die $used, ': cannot close';
297
298  for my $i (2 .. @sources - 1) {
299    # Invoke the diff3 command to merge
300    my $mine = ($i == 2 ? $sources[1]->cache : $used);
301    my $older = $sources[0]->cache;
302    my $yours = $sources[$i]->cache;
303    my @command = (
304      $self->setting (qw/TOOL DIFF3/),
305      split (/\s+/, $self->setting (qw/TOOL DIFF3FLAGS/)),
306      $mine, $older, $yours,
307    );
308    my $code;
309    my @out = &run_command (
310      \@command,
311      METHOD => 'qx',
312      ERROR  => 'ignore',
313      PRINT  => $self->verbose > 1,
314      RC     => \$code,
315      TIME   => $self->verbose > 2,
316    );
317
318    if ($code) {
319      # Failure, report and return
320      my $m = ($code == 1)
321              ? 'cannot resolve conflicts:'
322              : $self->setting (qw/TOOL DIFF3/) . 'command failed';
323      w_report 'ERROR: ', $self->pkgname, ': merge - ', $m;
324      if ($code == 1 and $self->verbose) {
325        for (0 .. $i) {
326          my $src = $sources[$_]->uri eq $sources[$_]->cache
327                    ? $sources[$_]->cache
328                    : ($sources[$_]->uri . '@' . $sources[$_]->rev);
329          w_report '  source[', $_, ']=', $src;
330        }
331
332        for (0 .. $i) {
333          w_report '  cache', $_, '=', $sources[$_]->cache;
334        }
335
336        w_report @out if $self->verbose > 2;
337      }
338      $rc = undef;
339      last;
340
341    } else {
342      # Success, write result to temporary file
343      open FILE, '>', $used or die $used, ': cannot open (', $!, ')';
344      print FILE @out;
345      close FILE or die $used, ': cannot close (', $!, ')';
346
347      # File permission, use most permissive combination of $mine and $yours
348      my $perm = ((stat($mine))[2] & 07777) | ((stat($yours))[2] & 07777);
349      chmod ($perm, $used);
350    }
351  }
352
353  return ($rc, $used);
354}
355
356# ------------------------------------------------------------------------------
357# SYNOPSIS
358#   $rc = $obj->run_update($used_file);
359#
360# DESCRIPTION
361#   This method is part of run(). It compares the $used_file with the one in
362#   the destination. If the file does not exist in the destination or if its
363#   content is out of date, the destination is updated with the content in the
364#   $used_file. Returns true on success.
365# ------------------------------------------------------------------------------
366
367sub run_update {
368  my ($self, $used_file) = @_;
369  my ($is_diff, $is_diff_in_perms, $is_in_prev, $rc) = (1, 1, undef, 1);
370
371  # Compare with the previous version if it exists
372  DEST:
373  for my $i (0 .. @{$self->dest()} - 1) {
374    my $prev_file = File::Spec->catfile($self->dest()->[$i], $self->pkgname());
375    if (-f $prev_file) {
376      $is_in_prev = $i;
377      $is_diff = compare($used_file, $prev_file);
378      $is_diff_in_perms = (stat($used_file))[2] != (stat($prev_file))[2];
379      last DEST;
380    }
381  }
382  if (!$is_diff && !$is_diff_in_perms) {
383    return $rc;
384  }
385
386  # Update destination
387  my $dest_file = File::Spec->catfile($self->dest()->[0], $self->pkgname());
388  if ($is_diff) {
389    my $dir = dirname($dest_file);
390    if (!-d $dir) {
391      mkpath($dir);
392    }
393    $rc = copy($used_file, $dest_file);
394  }
395  $rc &&= chmod((stat($used_file))[2] & oct(7777), $dest_file);
396  if ($rc) {
397    $self->dest_status(
398        $is_in_prev          ? 'a'
399      : defined($is_in_prev) ? 'M'
400      :                        'A'
401    );
402  }
403  return $rc;
404}
405
406# ------------------------------------------------------------------------------
407
4081;
409
410__END__
Note: See TracBrowser for help on using the repository browser.