265 lines
7.3 KiB
Perl
Executable File
265 lines
7.3 KiB
Perl
Executable File
# ------------------------------------------------------------------------------
|
|
# 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.
|
|
# ------------------------------------------------------------------------------
|
|
use warnings;
|
|
use strict;
|
|
|
|
package Fcm::SrcDirLayer;
|
|
use base qw{Fcm::Base};
|
|
|
|
use Fcm::Util qw{run_command e_report w_report};
|
|
use File::Basename qw{dirname};
|
|
use File::Path qw{mkpath};
|
|
use File::Spec;
|
|
|
|
# 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")
|
|
);
|
|
|
|
my %ERR_MESS_OF = (
|
|
CACHE_WRITE => '%s: cannot write to cache',
|
|
SYMLINK => '%s/%s: ignore symbolic link',
|
|
VC_TYPE => '%s: repository type not supported',
|
|
);
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# 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};
|
|
}
|
|
}
|
|
|
|
# Handles error/warning events.
|
|
sub _err {
|
|
my ($key, $args_ref, $warn_only) = @_;
|
|
my $reporter = $warn_only ? \&w_report : \&e_report;
|
|
$args_ref ||= [];
|
|
$reporter->(sprintf($ERR_MESS_OF{$key} . ".\n", @{$args_ref}));
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# 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 {
|
|
_err('VC_TYPE', [$self->type()]);
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# 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 (!-w $dirname) {
|
|
_err('CACHE_WRITE', [$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 {
|
|
_err('VC_TYPE', [$self->type()]);
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# @files = $obj->get_files();
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a list of file base names in the (cache of) this source
|
|
# directory in the current branch.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub get_files {
|
|
my ($self) = @_;
|
|
opendir(my $dir, $self->localdir())
|
|
|| die($self->localdir(), ': cannot read directory');
|
|
my @base_names = ();
|
|
BASE_NAME:
|
|
while (my $base_name = readdir($dir)) {
|
|
if ($base_name =~ qr{\A\.}xms || $base_name =~ qr{~\z}xms) {
|
|
next BASE_NAME;
|
|
}
|
|
my $path = File::Spec->catfile($self->localdir(), $base_name);
|
|
if (-d $path) {
|
|
next BASE_NAME;
|
|
}
|
|
if (-l $path) {
|
|
_err('SYMLINK', [$self->location(), $base_name], 1);
|
|
next BASE_NAME;
|
|
}
|
|
push(@base_names, $base_name);
|
|
}
|
|
closedir($dir);
|
|
$self->files(\@base_names);
|
|
return @base_names;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
|
|
1;
|
|
|
|
__END__
|