source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM1/ExtractFile.pm @ 5134

Last change on this file since 5134 was 5129, checked in by abarral, 5 months ago

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