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

#!/usr/bin/perl
# ------------------------------------------------------------------------------
# NAME
#   Fcm::SrcDirLayer
#
# DESCRIPTION
#   This class contains methods to manipulate the extract of a source
#   directory from a branch of a (Subversion) repository.
#
# 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.
# ------------------------------------------------------------------------------

package Fcm::SrcDirLayer;
@ISA = qw(Fcm::Base);

# Standard pragma
use warnings;
use strict;

# Standard modules
use File::Basename;
use File::Path;
use File::Spec::Functions;

# FCM component modules
use Fcm::Base;
use Fcm::Timer;
use Fcm::Util;

# List of property methods for this class
my @scalar_properties = (
  'cachedir',  # cache directory for this directory branch
  'commit',    # revision at which the source directory was changed
  'extracted', # is this branch already extracted?
  'files',     # list of source files in this directory branch
  'location',  # location of the source directory in the branch
  'name',      # sub-package name of the source directory
  'package',   # top level package name of which the current repository belongs
  'reposroot', # repository root URL
  'revision',  # revision of the repository branch
  'tag',       # package/revision tag of the current repository branch
  'type',      # type of the repository branch ("svn" or "user")
);

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $obj = Fcm::SrcDirLayer->new (%args);
#
# DESCRIPTION
#   This method constructs a new instance of the Fcm::SrcDirLayer class. See
#   above for allowed list of properties. (KEYS should be in uppercase.)
# ------------------------------------------------------------------------------

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

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

  for (@scalar_properties) {
    $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : 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 'files') {
        # Reference to an array
        $self->{$name} = [];
      }
    }

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

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $dir = $obj->localdir;
#
# DESCRIPTION
#   This method returns the user or cache directory for the current revision
#   of the repository branch.
# ------------------------------------------------------------------------------

sub localdir {
  my $self = shift;

  return $self->user ? $self->location : $self->cachedir;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $user = $obj->user;
#
# DESCRIPTION
#   This method returns the string "user" if the current source directory
#   branch is a local directory. Otherwise, it returns "undef".
# ------------------------------------------------------------------------------

sub user {
  my $self = shift;

  return $self->type eq 'user' ? 'user' : undef;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rev = $obj->get_commit;
#
# DESCRIPTION
#   If the current repository type is "svn", this method attempts to obtain
#   the revision in which the branch is last committed. On a successful
#   operation, it returns this revision number. Otherwise, it returns
#   "undef".
# ------------------------------------------------------------------------------

sub get_commit {
  my $self = shift;

  if ($self->type eq 'svn') {
    # Execute the "svn info" command
    my @lines   = &run_command (
      [qw/svn info -r/, $self->revision, $self->location . '@' . $self->revision],
      METHOD => 'qx', TIME => $self->config->verbose > 2,
    );

    my $rev;
    for (@lines) {
      if (/^Last\s+Changed\s+Rev\s*:\s*(\d+)/i) {
        $rev = $1;
        last;
      }
    }

    # Commit revision of this source directory
    $self->commit ($rev);

    return $self->commit;

  } elsif ($self->type eq 'user') {
    return;

  } else {
    e_report 'Repository type "', $self->type, '" not supported.';
  }
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $rc = $obj->update_cache;
#
# DESCRIPTION
#   If the current repository type is "svn", this method attempts to extract
#   the current revision source directory from the current branch from the
#   repository, sending the output to the cache directory. It returns true on
#   a successful operation, or false if the repository is not of type "svn".
# ------------------------------------------------------------------------------

sub update_cache {
  my $self = shift;

  return unless $self->cachedir;

  # Create cache extract destination, if necessary
  my $dirname = dirname $self->cachedir;
  mkpath $dirname if not -d $dirname;

  e_report $dirname, ': cannot write to cache, abort.'
    unless -d $dirname and -w $dirname;
  
  if ($self->type eq 'svn') {
    # Set up the extract command, "svn export --force -q -N"
    my @command = (
      qw/svn export --force -q -N/,
      $self->location . '@' . $self->revision,
      $self->cachedir,
    );

    &run_command (\@command, TIME => $self->config->verbose > 2);

  } elsif ($self->type eq 'user') {
    return;

  } else {
    e_report 'Repository type "', $self->type, '" not supported.';
  }

  return 1;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   @files = $obj->get_files;
#
# DESCRIPTION
#   This method returns a list of files in the cache or local user directory
#   of the current revision of the source directory in the current branch.
# ------------------------------------------------------------------------------

sub get_files {
  my $self = shift;

  # Get a list of files in the cache (or local user) directory
  my @files = ();

  opendir (DIR, $self->localdir)
    or die $self->localdir, ': cannot read directory';

  while (my $file = readdir DIR) {
    next if $file =~ /^\.\.?/;                   # ignore . and .. and hidden
    next if $file =~ /~$/;                       # ignore emacs swap files
    next if -d catfile ($self->localdir, $file); # ignore sub-directories
    push @files, $file;
  }
  closedir DIR;

  # Return the (base name) of the list of files
  $self->files (\@files);
  return @files;
}

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

1;

__END__