ecearth3/sources/nemo-3.6/EXTERNAL/fcm/lib/Fcm/ExtractFile.pm

# ------------------------------------------------------------------------------
# NAME
#   Fcm::ExtractFile
#
# DESCRIPTION
#   Select/combine a file in different branches and extract it to destination.
#
# COPYRIGHT
#   (C) Crown copyright Met Office. All rights reserved.
#   For further details please refer to the file COPYRIGHT.txt
#   which you should have received as part of this distribution.
# ------------------------------------------------------------------------------

use warnings;
use strict;

package Fcm::ExtractFile;
use base qw{Fcm::Base};

use Fcm::Util      qw{run_command w_report};
use File::Basename qw{dirname};
use File::Compare  qw{compare};
use File::Copy     qw{copy};
use File::Path     qw{mkpath};
use File::Spec;
use File::Temp     qw(tempfile);

# List of property methods for this class
my @scalar_properties = (
  'conflict',    # conflict mode
  'dest',        # search path to destination file
  'dest_status', # destination status, see below
  'pkgname',     # package name of this file
  'src',         # list of Fcm::ExtractSrc, specified for this file
  'src_actual',  # list of Fcm::ExtractSrc, actually used by this file
  'src_status',  # source status, see below
);

# Status code definition for $self->dest_status
our %DEST_STATUS_CODE = (
  ''  => 'unchanged',
  'M' => 'modified',
  'A' => 'added',
  'a' => 'added, overridding inherited',
  'D' => 'deleted',
  'd' => 'deleted, overridding inherited',
  '?' => 'irrelevant',
);

# Status code definition for $self->src_status
our %SRC_STATUS_CODE = (
  'A' => 'added by a branch',
  'B' => 'from the base',
  'D' => 'deleted by a branch',
  'M' => 'modified by a branch',
  'G' => 'merged from 2+ branches',
  'O' => 'overridden by a branch',
  '?' => 'irrelevant',
);

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $obj = Fcm::ExtractFile->new ();
#
# DESCRIPTION
#   This method constructs a new instance of the Fcm::ExtractFile class.
# ------------------------------------------------------------------------------

sub new {
  my $this  = shift;
  my %args  = @_;
  my $class = ref $this || $this;

  my $self = Fcm::Base->new (%args);

  for (@scalar_properties) {
    $self->{$_} = exists $args{$_} ? $args{$_} : undef;
  }

  bless $self, $class;
  return $self;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $value = $obj->X;
#   $obj->X ($value);
#
# DESCRIPTION
#   Details of these properties are explained in @scalar_properties.
# ------------------------------------------------------------------------------

for my $name (@scalar_properties) {
  no strict 'refs';

  *$name = sub {
    my $self = shift;

    # Argument specified, set property to specified argument
    if (@_) {
      $self->{$name} = $_[0];
    }

    # Default value for property
    if (not defined $self->{$name}) {
      if ($name eq 'conflict') {
        $self->{$name} = 'merge'; # default to "merge" mode

      } elsif ($name eq 'dest' or $name eq 'src' or $name eq 'src_actual') {
        $self->{$name} = [];      # default to an empty list
      }
    }

    return $self->{$name};
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = $obj->run();
#
# DESCRIPTION
#   This method runs only if $self->dest_status is not defined. It updates the
#   destination according to the source in the list and the conflict mode
#   setting. It updates the file in $self->dest as appropriate and sets
#   $self->dest_status. (See above.) This method returns true on success.
# ------------------------------------------------------------------------------

sub run {
  my ($self) = @_;
  my $rc = 1;

  if (not defined ($self->dest_status)) {
    # Assume file unchanged
    $self->dest_status ('');

    if (@{ $self->src }) {
      my $used;
      # Determine or set up a file for comparing with the destination
      ($rc, $used) = $self->run_get_used();

      # Attempt to compare the destination with $used. Update on change.
      if ($rc) {
        $rc = defined ($used) ? $self->run_update($used) : $self->run_delete();
      }

    } else {
      # No source, delete file in destination
      $self->src_status ('?');
      $rc = $self->run_delete();
    }
  }

  return $rc;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = $obj->run_delete();
#
# DESCRIPTION
#   This method is part of run(). It detects this file in the destination path.
#   If this file is in the current destination, it attempts to delete it and
#   sets the dest_status to "D". If this file is in an inherited destination,
#   it sets the dest_status to "d".
# ------------------------------------------------------------------------------

sub run_delete {
  my ($self) = @_;

  my $rc = 1;

  $self->dest_status ('?');
  for my $i (0 .. @{ $self->dest } - 1) {
    my $dest = File::Spec->catfile ($self->dest->[$i], $self->pkgname);
    next unless -f $dest;
    if ($i == 0) {
      $rc = unlink $dest;
      $self->dest_status ('D');

    } else {
      $self->dest_status ('d');
      last;
    }
  }

  return $rc;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   ($rc, $used) = $obj->run_get_used();
#
# DESCRIPTION
#   This method is part of run(). It attempts to work out or set up the $used
#   file. ($used is undef if it is not defined in a branch for this file.)
# ------------------------------------------------------------------------------

sub run_get_used {
  my ($self) = @_;
  my $rc = 1;
  my $used;

  my @sources = ($self->src->[0]);
  my $src_status = 'B';
  if (defined ($self->src->[0]->cache)) {
    # File exists in base branch
    for my $i (1 .. @{ $self->src } - 1) {
      if (defined ($self->src->[$i]->cache)) {
        # Detect changes in this file between base branch and branch $i
        push @sources, $self->src->[$i]
          if &compare ($self->src->[0]->cache, $self->src->[$i]->cache);

      } else {
        # File deleted in branch $i
        @sources = ($self->src->[$i]);
        last unless $self->conflict eq 'override';
      }
    }

    if ($rc) {
      if (@sources > 2) {
        if ($self->conflict eq 'fail') {
          # On conflict, fail in fail mode
          w_report 'ERROR: ', $self->pkgname,
                   ': modified in 2+ branches in fail conflict mode.';
          $rc = undef;

        } elsif ($self->conflict eq 'override') {
          $used = $sources[-1]->cache;
          $src_status = 'O';

        } else {
          # On conflict, attempt to merge in merge mode
          ($rc, $used) = $self->run_get_used_by_merge (@sources);
          $src_status = 'G' if $rc;
        }

      } else {
        # 0 or 1 change, use last source
        if (defined $sources[-1]->cache) {
          $used = $sources[-1]->cache;
          $src_status = 'M' if @sources > 1;

        } else {
          $src_status = 'D';
        }
      }
    }

  } else {
    # File does not exist in base branch
    @sources = ($self->src->[-1]);
    $used = $self->src->[1]->cache;
    $src_status = (defined ($used) ? 'A' : 'D');
    if ($self->conflict ne 'override' and defined ($used)) {
      for my $i (1 - @{ $self->src } .. -2) {
        # Allow this only if files are the same in all branches
        my $file = $self->src->[$i]->cache;
        if ((not defined ($file)) or &compare ($used, $file)) {
          w_report 'ERROR: ', $self->pkgname, ': cannot merge:',
                   ' not found in base branch,',
                   ' but differs in subsequent branches.';
          $rc = undef;
          last;

        } else {
          unshift @sources, $self->src->[$i];
        }
      }
    }
  }

  $self->src_status ($src_status);
  $self->src_actual (\@sources);

  return ($rc, $used);
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   ($rc, $used) = $obj->run_get_used_by_merge(@soruces);
#
# DESCRIPTION
#   This method is part of run_get_used(). It attempts to merge the files in
#   @sources and return a temporary file $used. @sources should be an array of
#   Fcm::ExtractSrc objects. On success, $rc will be set to true.
# ------------------------------------------------------------------------------

sub run_get_used_by_merge {
  my ($self, @sources) = @_;
  my $rc = 1;

  # Get temporary file
  my ($fh, $used) = &tempfile ('fcm.ext.merge.XXXXXX', UNLINK => 1);
  close $fh or die $used, ': cannot close';

  for my $i (2 .. @sources - 1) {
    # Invoke the diff3 command to merge
    my $mine = ($i == 2 ? $sources[1]->cache : $used);
    my $older = $sources[0]->cache;
    my $yours = $sources[$i]->cache;
    my @command = (
      $self->setting (qw/TOOL DIFF3/),
      split (/\s+/, $self->setting (qw/TOOL DIFF3FLAGS/)),
      $mine, $older, $yours,
    );
    my $code;
    my @out = &run_command (
      \@command,
      METHOD => 'qx',
      ERROR  => 'ignore',
      PRINT  => $self->verbose > 1,
      RC     => \$code,
      TIME   => $self->verbose > 2,
    );

    if ($code) {
      # Failure, report and return
      my $m = ($code == 1)
              ? 'cannot resolve conflicts:'
              : $self->setting (qw/TOOL DIFF3/) . 'command failed';
      w_report 'ERROR: ', $self->pkgname, ': merge - ', $m;
      if ($code == 1 and $self->verbose) {
        for (0 .. $i) {
          my $src = $sources[$_]->uri eq $sources[$_]->cache
                    ? $sources[$_]->cache
                    : ($sources[$_]->uri . '@' . $sources[$_]->rev);
          w_report '  source[', $_, ']=', $src;
        }

        for (0 .. $i) {
          w_report '  cache', $_, '=', $sources[$_]->cache;
        }

        w_report @out if $self->verbose > 2;
      }
      $rc = undef;
      last;

    } else {
      # Success, write result to temporary file
      open FILE, '>', $used or die $used, ': cannot open (', $!, ')';
      print FILE @out;
      close FILE or die $used, ': cannot close (', $!, ')';

      # File permission, use most permissive combination of $mine and $yours
      my $perm = ((stat($mine))[2] & 07777) | ((stat($yours))[2] & 07777);
      chmod ($perm, $used);
    }
  }

  return ($rc, $used);
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = $obj->run_update($used_file);
#
# DESCRIPTION
#   This method is part of run(). It compares the $used_file with the one in
#   the destination. If the file does not exist in the destination or if its
#   content is out of date, the destination is updated with the content in the
#   $used_file. Returns true on success.
# ------------------------------------------------------------------------------

sub run_update {
  my ($self, $used_file) = @_;
  my ($is_diff, $is_diff_in_perms, $is_in_prev, $rc) = (1, 1, undef, 1);

  # Compare with the previous version if it exists
  DEST:
  for my $i (0 .. @{$self->dest()} - 1) {
    my $prev_file = File::Spec->catfile($self->dest()->[$i], $self->pkgname());
    if (-f $prev_file) {
      $is_in_prev = $i;
      $is_diff = compare($used_file, $prev_file);
      $is_diff_in_perms = (stat($used_file))[2] != (stat($prev_file))[2];
      last DEST;
    }
  }
  if (!$is_diff && !$is_diff_in_perms) {
    return $rc;
  }

  # Update destination
  my $dest_file = File::Spec->catfile($self->dest()->[0], $self->pkgname());
  if ($is_diff) {
    my $dir = dirname($dest_file);
    if (!-d $dir) {
      mkpath($dir);
    }
    $rc = copy($used_file, $dest_file);
  }
  $rc &&= chmod((stat($used_file))[2] & oct(7777), $dest_file);
  if ($rc) {
    $self->dest_status(
        $is_in_prev          ? 'a'
      : defined($is_in_prev) ? 'M'
      :                        'A'
    );
  }
  return $rc;
}

# ------------------------------------------------------------------------------

1;

__END__