888 lines
26 KiB
Perl
Executable File
888 lines
26 KiB
Perl
Executable File
# ------------------------------------------------------------------------------
|
|
# NAME
|
|
# Fcm::Dest
|
|
#
|
|
# DESCRIPTION
|
|
# This class contains methods to set up a destination location of an FCM
|
|
# extract/build.
|
|
#
|
|
# 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::Dest;
|
|
use base qw{Fcm::Base};
|
|
|
|
use Carp qw{croak} ;
|
|
use Cwd qw{cwd} ;
|
|
use Fcm::CfgLine ;
|
|
use Fcm::Timer qw{timestamp_command} ;
|
|
use Fcm::Util qw{run_command touch_file w_report};
|
|
use File::Basename qw{basename dirname} ;
|
|
use File::Find qw{find} ;
|
|
use File::Path qw{mkpath rmtree} ;
|
|
use File::Spec ;
|
|
use Sys::Hostname qw{hostname} ;
|
|
use Text::ParseWords qw{shellwords} ;
|
|
|
|
# Useful variables
|
|
# ------------------------------------------------------------------------------
|
|
# List of configuration files
|
|
our @cfgfiles = (
|
|
'bldcfg', # default location of the build configuration file
|
|
'extcfg', # default location of the extract configuration file
|
|
);
|
|
|
|
# List of cache and configuration files, according to the dest type
|
|
our @cfgfiles_type = (
|
|
'cache', # default location of the cache file
|
|
'cfg', # default location of the configuration file
|
|
'parsedcfg', # default location of the as-parsed configuration file
|
|
);
|
|
|
|
# List of lock files
|
|
our @lockfiles = (
|
|
'bldlock', # the build lock file
|
|
'extlock', # the extract lock file
|
|
);
|
|
|
|
# List of misc files
|
|
our @miscfiles_bld = (
|
|
'bldrunenvsh', # the build run environment shell script
|
|
'bldmakefile', # the build Makefile
|
|
);
|
|
|
|
# List of sub-directories created by extract
|
|
our @subdirs_ext = (
|
|
'cfgdir', # sub-directory for configuration files
|
|
'srcdir', # sub-directory for source tree
|
|
);
|
|
|
|
# List of sub-directories that can be archived by "tar" at end of build
|
|
our @subdirs_tar = (
|
|
'donedir', # sub-directory for "done" files
|
|
'flagsdir', # sub-directory for "flags" files
|
|
'incdir', # sub-directory for include files
|
|
'ppsrcdir', # sub-directory for pre-process source tree
|
|
'objdir', # sub-directory for object files
|
|
);
|
|
|
|
# List of sub-directories created by build
|
|
our @subdirs_bld = (
|
|
'bindir', # sub-directory for executables
|
|
'etcdir', # sub-directory for miscellaneous files
|
|
'libdir', # sub-directory for object libraries
|
|
'tmpdir', # sub-directory for temporary build files
|
|
@subdirs_tar, # -see above-
|
|
);
|
|
|
|
# List of sub-directories under rootdir
|
|
our @subdirs = (
|
|
'cachedir', # sub-directory for caches
|
|
@subdirs_ext, # -see above-
|
|
@subdirs_bld, # -see above-
|
|
);
|
|
|
|
# List of inherited search paths
|
|
# "rootdir" + all @subdirs, with "XXXdir" replaced with "XXXpath"
|
|
our @paths = (
|
|
'rootpath',
|
|
(map {my $key = $_; $key =~ s{dir\z}{path}msx; $key} @subdirs),
|
|
);
|
|
|
|
# List of properties and their default values.
|
|
my %PROP_OF = (
|
|
# the original destination (if current destination is a mirror)
|
|
'dest0' => undef,
|
|
# list of inherited Fcm::Dest objects
|
|
'inherit' => [],
|
|
# remote login name
|
|
'logname' => scalar(getpwuid($<)),
|
|
# lock file
|
|
'lockfile' => undef,
|
|
# remote machine
|
|
'machine' => hostname(),
|
|
# mirror command to use
|
|
'mirror_cmd' => 'rsync',
|
|
# (for rsync) remote mkdir, the remote shell command
|
|
'rsh_mkdir_rsh' => 'ssh',
|
|
# (for rsync) remote mkdir, the remote shell command flags
|
|
'rsh_mkdir_rshflags' => '-n -oBatchMode=yes',
|
|
# (for rsync) remote mkdir, the remote shell command
|
|
'rsh_mkdir_mkdir' => 'mkdir',
|
|
# (for rsync) remote mkdir, the remote shell command flags
|
|
'rsh_mkdir_mkdirflags' => '-p',
|
|
# (for rsync) remote mkdir, the remote shell command
|
|
'rsync' => 'rsync',
|
|
# (for rsync) remote mkdir, the remote shell command flags
|
|
'rsyncflags' => q{-a --exclude='.*' --delete-excluded}
|
|
. q{ --timeout=900 --rsh='ssh -oBatchMode=yes'},
|
|
# destination root directory
|
|
'rootdir' => undef,
|
|
# destination type, "bld" (default) or "ext"
|
|
'type' => 'bld',
|
|
);
|
|
# Hook for property setter
|
|
my %PROP_HOOK_OF = (
|
|
'inherit' => \&_reset_inherit,
|
|
'rootdir' => \&_reset_rootdir,
|
|
);
|
|
|
|
# Mirror implementations
|
|
my %MIRROR_IMPL_OF = (
|
|
rdist => \&_mirror_with_rdist,
|
|
rsync => \&_mirror_with_rsync,
|
|
);
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $obj = Fcm::Dest->new(%args);
|
|
#
|
|
# DESCRIPTION
|
|
# This method constructs a new instance of the Fcm::Dest class. See above for
|
|
# allowed list of properties. (KEYS should be in uppercase.)
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub new {
|
|
my ($class, %args) = @_;
|
|
my $self = bless(Fcm::Base->new(%args), $class);
|
|
while (my ($key, $value) = each(%args)) {
|
|
$key = lc($key);
|
|
if (exists($PROP_OF{$key})) {
|
|
$self->{$key} = $value;
|
|
}
|
|
}
|
|
for my $key (@subdirs, @paths, @lockfiles, @cfgfiles) {
|
|
$self->{$key} = undef;
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $self->DESTROY;
|
|
#
|
|
# DESCRIPTION
|
|
# This method is called automatically when the Fcm::Dest object is
|
|
# destroyed.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub DESTROY {
|
|
my $self = shift;
|
|
|
|
# Remove the lockfile if it is set
|
|
unlink $self->lockfile if $self->lockfile and -w $self->lockfile;
|
|
|
|
return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $value = $obj->X($value);
|
|
#
|
|
# DESCRIPTION
|
|
# Details of these properties are explained in %PROP_OF.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
while (my ($key, $default) = each(%PROP_OF)) {
|
|
no strict 'refs';
|
|
*{$key} = sub {
|
|
my $self = shift();
|
|
# Set property to specified value
|
|
if (@_) {
|
|
$self->{$key} = $_[0];
|
|
if (exists($PROP_HOOK_OF{$key})) {
|
|
$PROP_HOOK_OF{$key}->($self, $key);
|
|
}
|
|
}
|
|
# Sets default where possible
|
|
if (!defined($self->{$key})) {
|
|
$self->{$key} = $default;
|
|
}
|
|
return $self->{$key};
|
|
};
|
|
}
|
|
|
|
# Remote shell property: deprecated.
|
|
sub remote_shell {
|
|
my $self = shift();
|
|
$self->rsh_mkdir_rsh(@_);
|
|
}
|
|
|
|
# Resets properties associated with root directory.
|
|
sub _reset_rootdir {
|
|
my $self = shift();
|
|
for my $key (@cfgfiles, @lockfiles, @miscfiles_bld, @subdirs) {
|
|
$self->{$key} = undef;
|
|
}
|
|
}
|
|
|
|
# Reset properties associated with inherited paths.
|
|
sub _reset_inherit {
|
|
my $self = shift();
|
|
for my $key (@paths) {
|
|
$self->{$key} = undef;
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $value = $obj->X;
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns X, where X is a location derived from rootdir, and can
|
|
# be one of:
|
|
# bindir, bldcfg, blddir, bldlock, bldrunenv, cache, cachedir, cfg, cfgdir,
|
|
# donedir, etcdir, extcfg, extlock, flagsdir, incdir, libdir, parsedcfg,
|
|
# ppsrcdir, objdir, or tmpdir.
|
|
#
|
|
# Details of these properties are explained earlier.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
for my $name (@cfgfiles, @cfgfiles_type, @lockfiles, @miscfiles_bld, @subdirs) {
|
|
no strict 'refs';
|
|
|
|
*$name = sub {
|
|
my $self = shift;
|
|
|
|
# If variable not set, derive it from rootdir
|
|
if ($self->rootdir and not defined $self->{$name}) {
|
|
if ($name eq 'cache') {
|
|
# Cache file under root/.cache
|
|
$self->{$name} = File::Spec->catfile (
|
|
$self->cachedir, $self->setting ('CACHE'),
|
|
);
|
|
|
|
} elsif ($name eq 'cfg') {
|
|
# Configuration file of current type
|
|
my $method = $self->type . 'cfg';
|
|
$self->{$name} = $self->$method;
|
|
|
|
} elsif (grep {$name eq $_} @cfgfiles) {
|
|
# Configuration files under the root/cfg
|
|
(my $label = uc ($name)) =~ s/CFG//;
|
|
$self->{$name} = File::Spec->catfile (
|
|
$self->cfgdir, $self->setting ('CFG_NAME', $label),
|
|
);
|
|
|
|
} elsif (grep {$name eq $_} @lockfiles) {
|
|
# Lock file
|
|
$self->{$name} = File::Spec->catfile (
|
|
$self->rootdir, $self->setting ('LOCK', uc ($name)),
|
|
);
|
|
|
|
} elsif (grep {$name eq $_} @miscfiles_bld) {
|
|
# Misc file
|
|
$self->{$name} = File::Spec->catfile (
|
|
$self->rootdir, $self->setting ('BLD_MISC', uc ($name)),
|
|
);
|
|
|
|
} elsif ($name eq 'parsedcfg') {
|
|
# As-parsed configuration file of current type
|
|
$self->{$name} = File::Spec->catfile (
|
|
dirname ($self->cfg),
|
|
$self->setting (qw/CFG_NAME PARSED/) . basename ($self->cfg),
|
|
)
|
|
|
|
} elsif (grep {$name eq $_} @subdirs) {
|
|
# Sub-directories under the root
|
|
(my $label = uc ($name)) =~ s/DIR//;
|
|
$self->{$name} = File::Spec->catfile (
|
|
$self->rootdir,
|
|
$self->setting ('DIR', $label),
|
|
($name eq 'cachedir' ? '.' . $self->type : ()),
|
|
);
|
|
}
|
|
}
|
|
|
|
return $self->{$name};
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $value = $obj->X;
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns X, an array containing the search path of a destination
|
|
# directory, which can be one of:
|
|
# binpath, bldpath, cachepath, cfgpath, donepath, etcpath, flagspath,
|
|
# incpath, libpath, ppsrcpath, objpath, rootpath, srcpath, or tmppath,
|
|
#
|
|
# Details of these properties are explained earlier.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
for my $name (@paths) {
|
|
no strict 'refs';
|
|
|
|
*$name = sub {
|
|
my $self = shift;
|
|
|
|
(my $dir = $name) =~ s/path/dir/;
|
|
|
|
if ($self->$dir and not defined $self->{$name}) {
|
|
my @path = ();
|
|
|
|
# Recursively inherit the search path
|
|
for my $d (@{ $self->inherit }) {
|
|
unshift @path, $d->$dir;
|
|
}
|
|
|
|
# Place the path of the current build in the front
|
|
unshift @path, $self->$dir;
|
|
|
|
$self->{$name} = \@path;
|
|
}
|
|
|
|
return $self->{$name};
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $obj->archive ();
|
|
#
|
|
# DESCRIPTION
|
|
# This method creates TAR archives for selected sub-directories.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub archive {
|
|
my $self = shift;
|
|
|
|
# Save current directory
|
|
my $cwd = cwd ();
|
|
|
|
my $tar = $self->setting (qw/OUTFILE_EXT TAR/);
|
|
my $verbose = $self->verbose;
|
|
|
|
for my $name (@subdirs_tar) {
|
|
my $dir = $self->$name;
|
|
|
|
# Ignore unless sub-directory exists
|
|
next unless -d $dir;
|
|
|
|
# Change to container directory
|
|
my $base = basename ($dir);
|
|
print 'cd ', dirname ($dir), "\n" if $verbose > 2;
|
|
chdir dirname ($dir);
|
|
|
|
# Run "tar" command
|
|
my $rc = &run_command (
|
|
[qw/tar -czf/, $base . $tar, $base],
|
|
PRINT => $verbose > 1, ERROR => 'warn',
|
|
);
|
|
|
|
# Remove sub-directory
|
|
&run_command ([qw/rm -rf/, $base], PRINT => $verbose > 1) if not $rc;
|
|
}
|
|
|
|
# Change back to "current" directory
|
|
print 'cd ', $cwd, "\n" if $verbose > 2;
|
|
chdir $cwd;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $authority = $obj->authority();
|
|
#
|
|
# DESCRIPTION
|
|
# Returns LOGNAME@MACHINE for this destination if LOGNAME is defined and not
|
|
# the same as the user ID of the current process. Returns MACHINE if LOGNAME
|
|
# is the same as the user ID of the current process, but MACHINE is not the
|
|
# same as the current hostname. Returns an empty string if LOGNAME and
|
|
# MACHINE are not defined or are the same as in the current process.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub authority {
|
|
my $self = shift;
|
|
my $return = '';
|
|
|
|
if ($self->logname ne $self->config->user_id) {
|
|
$return = $self->logname . '@' . $self->machine;
|
|
|
|
} elsif ($self->machine ne &hostname()) {
|
|
$return = $self->machine;
|
|
}
|
|
|
|
return $return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $obj->clean([ITEM => <list>,] [MODE => 'ALL|CONTENT|EMPTY',]);
|
|
#
|
|
# DESCRIPTION
|
|
# This method removes files/directories from the destination. If ITEM is set,
|
|
# it must be a reference to a list of method names for files/directories to
|
|
# be removed. Otherwise, the list is determined by the destination type. If
|
|
# MODE is ALL, all directories/files created by the extract/build are
|
|
# removed. If MODE is CONTENT, only contents within sub-directories are
|
|
# removed. If MODE is EMPTY (default), only empty sub-directories are
|
|
# removed.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub clean {
|
|
my ($self, %args) = @_;
|
|
my $mode = exists $args{MODE} ? $args{MODE} : 'EMPTY';
|
|
my $rc = 1;
|
|
my @names
|
|
= $args{ITEM} ? @{$args{ITEM}}
|
|
: $self->type() eq 'ext' ? ('cachedir', @subdirs_ext)
|
|
: ('cachedir', @subdirs_bld, @miscfiles_bld)
|
|
;
|
|
my @items;
|
|
if ($mode eq 'CONTENT') {
|
|
for my $name (@names) {
|
|
my $item = $self->$name();
|
|
push(@items, _directory_contents($item));
|
|
}
|
|
}
|
|
else {
|
|
for my $name (@names) {
|
|
my $item = $self->$name();
|
|
if ($mode eq 'ALL' || -d $item && !_directory_contents($item)) {
|
|
push(@items, $item);
|
|
}
|
|
}
|
|
}
|
|
for my $item (@items) {
|
|
if ($self->verbose() >= 2) {
|
|
printf("%s: remove\n", $item);
|
|
}
|
|
eval {rmtree($item)};
|
|
if ($@) {
|
|
w_report($@);
|
|
$rc = 0;
|
|
}
|
|
}
|
|
return $rc;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $obj->create ([DIR => <dir-list>,]);
|
|
#
|
|
# DESCRIPTION
|
|
# This method creates the directories of a destination. If DIR is set, it
|
|
# must be a reference to a list of sub-directories to be created. Otherwise,
|
|
# the sub-directory list is determined by the destination type. It returns
|
|
# true if the destination is created or if it exists and is writable.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub create {
|
|
my ($self, %args) = @_;
|
|
|
|
my $rc = 1;
|
|
|
|
my @dirs;
|
|
if (exists $args{DIR} and $args{DIR}) {
|
|
# Create only selected sub-directories
|
|
@dirs = @{ $args{DIR} };
|
|
|
|
} else {
|
|
# Create rootdir, cachedir and read-write sub-directories for extract/build
|
|
@dirs = (
|
|
qw/rootdir cachedir/,
|
|
($self->type eq 'ext' ? @subdirs_ext : @subdirs_bld),
|
|
);
|
|
}
|
|
|
|
for my $name (@dirs) {
|
|
my $dir = $self->$name;
|
|
|
|
# Create directory if it does not already exist
|
|
if (not -d $dir) {
|
|
print 'Make directory: ', $dir, "\n" if $self->verbose > 1;
|
|
mkpath $dir;
|
|
}
|
|
|
|
# Check whether directory exists and is writable
|
|
unless (-d $dir and -w $dir) {
|
|
w_report 'ERROR: ', $dir, ': cannot write to destination.';
|
|
$rc = 0;
|
|
}
|
|
}
|
|
|
|
return $rc;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $obj->create_bldrunenvsh ();
|
|
#
|
|
# DESCRIPTION
|
|
# This method creates the runtime environment script for the build.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub create_bldrunenvsh {
|
|
my $self = shift;
|
|
|
|
# Path to executable files and directory for misc files
|
|
my @bin_paths = grep {_directory_contents($_)} @{$self->binpath()};
|
|
my $bin_dir = -d $self->bindir() ? $self->bindir() : undef;
|
|
my $etc_dir = _directory_contents($self->etcdir()) ? $self->etcdir() : undef;
|
|
|
|
# Create a runtime environment script if necessary
|
|
if (@bin_paths || $etc_dir) {
|
|
my $path = $self->bldrunenvsh();
|
|
open(my $handle, '>', $path) || croak("$path: cannot open ($!)\n");
|
|
printf($handle "#!%s\n", $self->setting(qw/TOOL SHELL/));
|
|
if (@bin_paths) {
|
|
printf($handle "PATH=%s:\$PATH\n", join(':', @bin_paths));
|
|
print($handle "export PATH\n");
|
|
}
|
|
if ($etc_dir) {
|
|
printf($handle "FCM_ETCDIR=%s\n", $etc_dir);
|
|
print($handle "export FCM_ETCDIR\n");
|
|
}
|
|
close($handle) || croak("$path: cannot close ($!)\n");
|
|
|
|
# Create symbolic links fcm_env.ksh and bin/fcm_env.ksh for backward
|
|
# compatibility
|
|
my $FCM_ENV_KSH = 'fcm_env.ksh';
|
|
for my $link (
|
|
File::Spec->catfile($self->rootdir, $FCM_ENV_KSH),
|
|
($bin_dir ? File::Spec->catfile($bin_dir, $FCM_ENV_KSH) : ()),
|
|
) {
|
|
if (-l $link && readlink($link) ne $path || -e $link) {
|
|
unlink($link);
|
|
}
|
|
if (!-l $link) {
|
|
symlink($path, $link) || croak("$link: cannot create symbolic link\n");
|
|
}
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $obj->dearchive ();
|
|
#
|
|
# DESCRIPTION
|
|
# This method extracts from TAR archives for selected sub-directories.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub dearchive {
|
|
my $self = shift;
|
|
|
|
my $tar = $self->setting (qw/OUTFILE_EXT TAR/);
|
|
my $verbose = $self->verbose;
|
|
|
|
# Extract archives if necessary
|
|
for my $name (@subdirs_tar) {
|
|
my $tar_file = $self->$name . $tar;
|
|
|
|
# Check whether tar archive exists for the named sub-directory
|
|
next unless -f $tar_file;
|
|
|
|
# If so, extract the archive and remove it afterwards
|
|
&run_command ([qw/tar -xzf/, $tar_file], PRINT => $verbose > 1);
|
|
&run_command ([qw/rm -f/, $tar_file], PRINT => $verbose > 1);
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $name = $obj->get_pkgname_of_path ($path);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns the package name of $path if $path is in (a relative
|
|
# path of) $self->srcdir, or undef otherwise.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub get_pkgname_of_path {
|
|
my ($self, $path) = @_;
|
|
|
|
my $relpath = File::Spec->abs2rel ($path, $self->srcdir);
|
|
my $name = $relpath ? [File::Spec->splitdir ($relpath)] : undef;
|
|
|
|
return $name;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# %src = $obj->get_source_files ();
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a hash (keys = package names, values = file names)
|
|
# under $self->srcdir.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub get_source_files {
|
|
my $self = shift;
|
|
|
|
my %src;
|
|
if ($self->srcdir and -d $self->srcdir) {
|
|
&find (sub {
|
|
return if /^\./; # ignore system/hidden file
|
|
return if -d $File::Find::name; # ignore directory
|
|
return if not -r $File::Find::name; # ignore unreadable files
|
|
|
|
my $name = join (
|
|
'__', @{ $self->get_pkgname_of_path ($File::Find::name) },
|
|
);
|
|
$src{$name} = $File::Find::name;
|
|
}, $self->srcdir);
|
|
}
|
|
|
|
return \%src;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $obj->mirror (\@items);
|
|
#
|
|
# DESCRIPTION
|
|
# This method mirrors @items (list of method names for directories or files)
|
|
# from $dest0 (which must be an instance of Fcm::Dest for a local
|
|
# destination) to this destination.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub mirror {
|
|
my ($self, $items_ref) = @_;
|
|
if ($self->authority() || $self->dest0()->rootdir() ne $self->rootdir()) {
|
|
# Diagnostic
|
|
if ($self->verbose()) {
|
|
printf(
|
|
"Destination: %s\n",
|
|
($self->authority() ? $self->authority() . q{:} : q{}) . $self->rootdir()
|
|
);
|
|
}
|
|
if ($MIRROR_IMPL_OF{$self->mirror_cmd()}) {
|
|
$MIRROR_IMPL_OF{$self->mirror_cmd()}->($self, $self->dest0(), $items_ref);
|
|
}
|
|
else {
|
|
# Unknown mirroring tool
|
|
w_report($self->mirror_cmd, ': unknown mirroring tool, abort.');
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $self->_mirror_with_rdist ($dest0, \@items);
|
|
#
|
|
# DESCRIPTION
|
|
# This internal method implements $self->mirror with "rdist".
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub _mirror_with_rdist {
|
|
my ($self, $dest0, $items) = @_;
|
|
|
|
my $rhost = $self->authority ? $self->authority : &hostname();
|
|
|
|
# Print distfile content to temporary file
|
|
my @distfile = ();
|
|
for my $label (@$items) {
|
|
push @distfile, '( ' . $dest0->$label . ' ) -> ' . $rhost . "\n";
|
|
push @distfile, ' install ' . $self->$label . ';' . "\n";
|
|
}
|
|
|
|
# Set up mirroring command (use "rdist" at the moment)
|
|
my $command = 'rdist -R';
|
|
$command .= ' -q' unless $self->verbose > 1;
|
|
$command .= ' -f - 1>/dev/null';
|
|
|
|
# Diagnostic
|
|
my $croak = 'Cannot execute "' . $command . '"';
|
|
if ($self->verbose > 2) {
|
|
print timestamp_command ($command, 'Start');
|
|
print ' ', $_ for (@distfile);
|
|
}
|
|
|
|
# Execute the mirroring command
|
|
open COMMAND, '|-', $command or croak $croak, ' (', $!, '), abort';
|
|
for my $line (@distfile) {
|
|
print COMMAND $line;
|
|
}
|
|
close COMMAND or croak $croak, ' (', $?, '), abort';
|
|
|
|
# Diagnostic
|
|
print timestamp_command ($command, 'End ') if $self->verbose > 2;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $self->_mirror_with_rsync($dest0, \@items);
|
|
#
|
|
# DESCRIPTION
|
|
# This internal method implements $self->mirror() with "rsync".
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub _mirror_with_rsync {
|
|
my ($self, $dest0, $items_ref) = @_;
|
|
my @rsh_mkdir;
|
|
if ($self->authority()) {
|
|
@rsh_mkdir = (
|
|
$self->rsh_mkdir_rsh(),
|
|
shellwords($self->rsh_mkdir_rshflags()),
|
|
$self->authority(),
|
|
$self->rsh_mkdir_mkdir(),
|
|
shellwords($self->rsh_mkdir_mkdirflags()),
|
|
);
|
|
}
|
|
my @rsync = ($self->rsync(), shellwords($self->rsyncflags()));
|
|
my @rsync_verbose = ($self->verbose() > 2 ? '-v' : ());
|
|
my $auth = $self->authority() ? $self->authority() . q{:} : q{};
|
|
for my $item (@{$items_ref}) {
|
|
# Create container directory, as rsync does not do it automatically
|
|
my $dir = dirname($self->$item());
|
|
if (@rsh_mkdir) {
|
|
run_command([@rsh_mkdir, $dir], TIME => $self->verbose() > 2);
|
|
}
|
|
else {
|
|
mkpath($dir);
|
|
}
|
|
run_command(
|
|
[@rsync, @rsync_verbose, $dest0->$item(), $auth . $dir],
|
|
TIME => $self->verbose > 2,
|
|
);
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rc = $obj->set_lock ();
|
|
#
|
|
# DESCRIPTION
|
|
# This method sets a lock in the current destination.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub set_lock {
|
|
my $self = shift;
|
|
|
|
$self->lockfile ();
|
|
|
|
if ($self->type eq 'ext' and not $self->dest0) {
|
|
# Only set an extract lock for the local destination
|
|
$self->lockfile ($self->extlock);
|
|
|
|
} elsif ($self->type eq 'bld') {
|
|
# Set a build lock
|
|
$self->lockfile ($self->bldlock);
|
|
}
|
|
|
|
return &touch_file ($self->lockfile) if $self->lockfile;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# @cfglines = $obj->to_cfglines ([$index]);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a list of configuration lines for the current
|
|
# destination. If it is set, $index is the index number of the current
|
|
# destination.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub to_cfglines {
|
|
my ($self, $index) = @_;
|
|
|
|
my $PREFIX = $self->cfglabel($self->dest0() ? 'RDEST' : 'DEST');
|
|
my $SUFFIX = ($index ? $Fcm::Config::DELIMITER . $index : q{});
|
|
|
|
my @return = (
|
|
Fcm::CfgLine->new(label => $PREFIX . $SUFFIX, value => $self->rootdir()),
|
|
);
|
|
if ($self->dest0()) {
|
|
for my $name (qw{
|
|
logname
|
|
machine
|
|
mirror_cmd
|
|
rsh_mkdir_rsh
|
|
rsh_mkdir_rshflags
|
|
rsh_mkdir_mkdir
|
|
rsh_mkdir_mkdirflags
|
|
rsync
|
|
rsyncflags
|
|
}) {
|
|
if ($self->{$name} && $self->{$name} ne $PROP_OF{$name}) { # not default
|
|
push(
|
|
@return,
|
|
Fcm::CfgLine->new(
|
|
label => $PREFIX . $Fcm::Config::DELIMITER . uc($name) . $SUFFIX,
|
|
value => $self->{$name},
|
|
),
|
|
);
|
|
}
|
|
}
|
|
}
|
|
|
|
return @return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $string = $obj->write_rules ();
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a string containing Makefile variable declarations for
|
|
# directories and search paths in this destination.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub write_rules {
|
|
my $self = shift;
|
|
my $return = '';
|
|
|
|
# FCM_*DIR*
|
|
for my $i (0 .. @{ $self->inherit }) {
|
|
for my $name (@paths) {
|
|
(my $label = $name) =~ s/path$/dir/;
|
|
my $dir = $name eq 'rootpath' ? $self->$name->[$i] : File::Spec->catfile (
|
|
'$(FCM_ROOTDIR' . ($i ? $i : '') . ')',
|
|
File::Spec->abs2rel ($self->$name->[$i], $self->rootpath->[$i]),
|
|
);
|
|
|
|
$return .= ($i ? '' : 'export ') . 'FCM_' . uc ($label) . ($i ? $i : '') .
|
|
' := ' . $dir . "\n";
|
|
}
|
|
}
|
|
|
|
# FCM_*PATH
|
|
for my $name (@paths) {
|
|
(my $label = $name) =~ s/path$/dir/;
|
|
|
|
$return .= 'export FCM_' . uc ($name) . ' := ';
|
|
for my $i (0 .. @{ $self->$name } - 1) {
|
|
$return .= ($i ? ':' : '') . '$(FCM_' . uc ($label) . ($i ? $i : '') . ')';
|
|
}
|
|
$return .= "\n";
|
|
}
|
|
|
|
$return .= "\n";
|
|
|
|
return $return;
|
|
}
|
|
|
|
# Returns contents in directory.
|
|
sub _directory_contents {
|
|
my $path = shift();
|
|
if (!-d $path) {
|
|
return;
|
|
}
|
|
opendir(my $handle, $path) || croak("$path: cannot open directory ($!)\n");
|
|
my @items = grep {$_ ne q{.} && $_ ne q{..}} readdir($handle);
|
|
closedir($handle);
|
|
map {File::Spec->catfile($path . $_)} @items;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
|
|
1;
|
|
|
|
__END__
|