App-LXC-Container
view release on metacpan or search on metacpan
lib/App/LXC/Container.pm view on Meta::CPAN
$container name of the container to be configured
=head3 description:
This is the actual code for the wrapper script C<lxc-app-setup>.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub setup($)
{
defined $ENV{ALC_DEBUG} and $ENV{ALC_DEBUG} =~ m/^[0-9]+$/ and
debug($ENV{ALC_DEBUG});
my $container = App::LXC::Container::Setup->new(shift);
$container->main();
}
#########################################################################
=head2 B<update> - update LXC configuration
lib/App/LXC/Container.pm view on Meta::CPAN
@container name of the container(s) to be updated
=head3 description:
This is the actual code for the wrapper script C<lxc-app-update>.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub update(@)
{
defined $ENV{ALC_DEBUG} and $ENV{ALC_DEBUG} =~ m/^[0-9]+$/ and
debug($ENV{ALC_DEBUG});
my $container = App::LXC::Container::Update->new(@_);
$container->main();
}
#########################################################################
=head2 B<run> - run LXC configuration
lib/App/LXC/Container.pm view on Meta::CPAN
$container the name of the container to be run
=head3 description:
This is the actual code for the wrapper script C<lxc-app-run>.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub run(@)
{
my ($user, $dir) = ('root', '/');
while (2 < @_ and $_[0] =~ m/^(?:-[du]|--(?:dir|directory|user))$/)
{
if ($_[0] =~ m/^(-u|--user)$/)
{ shift; $user = shift; }
else
{ shift; $dir = shift; }
}
my $name = shift;
lib/App/LXC/Container/Data.pm view on Meta::CPAN
of the first one found. Note that only absolute paths are checked. Also
note that the executable must be indeed executable for the current user.
=head3 returns:
absolute path to the executable, C<undef> if not found
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub find_executable($)
{
my ($exec) = @_;
$exec =~ m|/|
and fatal 'internal_error__1', $exec . ' may not contain directory';
local $_;
foreach (split /:/, $ENV{PATH})
{
s|/+$||;
m|^/.+|
and -d $_
lib/App/LXC/Container/Data.pm view on Meta::CPAN
This function returns the list of all groups a user belongs to.
=head3 returns:
list of groups, should never be empty
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub groups_of($)
{
my ($user) = @_;
open my $id, '-|', 'id', '--groups', $user
or fatal 'can_t_open__1__2', 'id --groups ' . $user, $!;
my $groups = join(' ', <$id>);
close $id;
return split /\s+/, $groups;
}
#########################################################################
lib/App/LXC/Container/Data.pm view on Meta::CPAN
This function returns the initial list of containers using a network.
=head3 returns:
hard-coded header of network list
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub initial_network_list()
{
my @output =
('# list of all containers using a network (NUMBER:CONTAINER):',
'',
'# 1 is the LXC bridge!',
'2:local-network',
'3:network');
return @output;
}
lib/App/LXC/Container/Data.pm view on Meta::CPAN
audio within an application container. The content depends on the
distribution used.
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_audio_packages()
{
local $_ = _singleton();
return $_->content_audio_packages();
}
#########################################################################
=head2 B<content_device_default> - return default device configuration
@output = content_device_default();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
containers (C<lxc.> variables configuring the setup of the directory
C</dev>).
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_device_default()
{
local $_ = _singleton();
return $_->content_device_default();
}
#########################################################################
=head2 B<content_default_filter> - return default filter
@output = content_default_filter();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
automatically derived from packages. The content depends on the
distribution used.
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_default_filter()
{
local $_ = _singleton();
return $_->content_default_filter();
}
#########################################################################
=head2 B<content_default_mounts> - return default mount configuration
@output = content_default_mounts();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
This function returns the minimal mount configuration for the application
containers. The content depends on the distribution used.
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_default_mounts()
{
local $_ = _singleton();
return $_->content_default_mounts();
}
#########################################################################
=head2 B<content_default_packages> - return default packages
@output = content_default_packages();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
This function returns the minimal list of packages that are always needed
for application containers. The content depends on the distribution used.
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_default_packages()
{
local $_ = _singleton();
return $_->content_default_packages();
}
#########################################################################
=head2 B<content_network_default> - return default network configuration
@output = content_network_default();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
This function returns the basic network configuration for the application
containers (C<lxc.net.0.*>).
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_network_default()
{
local $_ = _singleton();
return $_->content_network_default();
}
#########################################################################
=head2 B<content_network_mounts> - return mount configuration for network
@output = content_network_mounts();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
applications having network access within the application container. The
content depends on the distribution used.
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_network_mounts()
{
local $_ = _singleton();
return $_->content_network_mounts();
}
#########################################################################
=head2 B<content_network_packages> - return package configuration for network
@output = content_network_packages();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
applications having network access within the application container. The
content depends on the distribution used.
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_network_packages()
{
local $_ = _singleton();
return $_->content_network_packages();
}
#########################################################################
=head2 B<content_x11_mounts> - return mount configuration for X11
@output = content_x11_mounts();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
applications within the application container. The content depends on the
distribution used.
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_x11_mounts()
{
local $_ = _singleton();
return $_->content_x11_mounts();
}
#########################################################################
=head2 B<content_x11_packages> - return mount configuration for X11
@output = content_x11_packages();
lib/App/LXC/Container/Data.pm view on Meta::CPAN
X11 within an application container. The content depends on the
distribution used.
=head3 returns:
array of configuration lines
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_x11_packages()
{
local $_ = _singleton();
return $_->content_x11_packages();
}
#########################################################################
=head2 depends_on - find installed dependencies of package
@packages = depends_on($package, $include);
lib/App/LXC/Container/Data.pm view on Meta::CPAN
list for performance reasons. The calling will not terminate if this is
changed.
=head3 returns:
all prerequisites of given package
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub depends_on($$)
{
my ($package, $include) = @_;
my $os_object = _singleton();
return $os_object->depends_on($package, $include);
}
#########################################################################
=head2 libraries_used - find package of executable
lib/App/LXC/Container/Data.pm view on Meta::CPAN
files) used by the given program or library, unless they do not return an
absolute path in L<C<ldd>> (e.g. C<linux-vdso.so.1>).
=head3 returns:
list of absolute paths to the libraries used
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub libraries_used($)
{
my ($executable) = @_;
my $os_object = _singleton();
return $os_object->libraries_used($executable);
}
#########################################################################
=head2 package_of - find package of file
lib/App/LXC/Container/Data.pm view on Meta::CPAN
This function searches for the given file in all installed packages and
returns the first one containing it.
=head3 returns:
name of first package containing given file, C<undef> if not found
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub package_of($)
{
my ($file) = @_;
my $os_object = _singleton();
$file = abs_path($file);
# 1. try direct path:
my $package = $os_object->package_of($file);
# 2. try existing symbolic links between / and /usr:
unless ($package)
{
# Due to abs_path above and variant distributions the branches and
lib/App/LXC/Container/Data.pm view on Meta::CPAN
This function returns a list of all absolute paths (files and maybe
directories) installed by the given package.
=head3 returns:
list of absolute paths
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub paths_of($)
{
my ($package) = @_;
my $os_object = _singleton();
return $os_object->paths_of($package);
}
#########################################################################
=head2 regular_users - return list of regular users
lib/App/LXC/Container/Data.pm view on Meta::CPAN
This function returns a list of all users on the system having a home
directory beneath a path beginning with /home.
=head3 returns:
list of all regular users
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub regular_users()
{
my $os_object = _singleton();
return $os_object->regular_users();
}
#########################################################################
#########################################################################
=head1 INTRNAL FUNCTIONS
lib/App/LXC/Container/Data/Debian.pm view on Meta::CPAN
#########################################################################
=head2 B<content_default_mounts> - return default mount configuration
Internal Object-oriented implementation of the function
L<App::LXC::Container::Data::content_default_mounts>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_default_mounts($$@)
{
local $_ = shift;
my @output =
($_->SUPER::content_default_mounts(@_),
'',
'# Debian:',
'/etc/debian_version');
return @output
}
########################################################################
=head2 depends_on - find package of file
internal object-oriented implementation of the function
L<App::LXC::Container::Data::depends_on>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub depends_on($$$)
{
my ($self, $package, $include) = @_;
$self->SUPER::depends_on($package, $include);
return () unless $self->_dpkg_status($package);
my @packages = ();
local $_;
# outer loop over all possible dependencies:
my @check = ('pre-depends', 'depends');
$include > 0 and push @check, 'recommends';
lib/App/LXC/Container/Data/Debian.pm view on Meta::CPAN
=head2 package_of - find package of file
internal object-oriented implementation of the function
L<App::LXC::Container::Data::package_of>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
use constant SEARCH => 'dpkg-query --search ';
sub package_of($$)
{
my ($self, $file) = @_;
$self->SUPER::package_of($file);
local $_;
# TODO: looks like pipe with redirection in shell never fails:
# uncoverable branch true
open my $dpkg, '-|', SEARCH . $file . ' 2>/dev/null'
or fatal('internal_error__1',
'error calling ' . SEARCH . $file . ': '. $!);
# escape special characters in file name:
lib/App/LXC/Container/Data/Debian.pm view on Meta::CPAN
=head2 paths_of - get list of paths of package
internal object-oriented implementation of the function
L<App::LXC::Container::Data::paths_of>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
use constant LISTFILES => 'dpkg-query --listfiles ';
sub paths_of($$)
{
my ($self, $package) = @_;
$self->SUPER::paths_of($package);
local $_;
# TODO: Better approach to get main architecture?
foreach ('', ':amd64', ':i386')
{
my $pa = $package . $_;
# TODO: as above:
# uncoverable branch true
lib/App/LXC/Container/Data/Debian.pm view on Meta::CPAN
requested information
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# List of installed packages, their dependencies and other information; this
# is only variable for the unit tests:
our $_dpkg_status = '/var/lib/dpkg/status';
sub _dpkg_status($$;$)
{
my ($self, $package, $key) = @_;
# parse and cache file if called for 1st time:
unless (defined $self->{STATUS})
{
my ($pkg, $stat) = ('');
open $stat, '<', $_dpkg_status
or fatal('can_t_open__1__2', $_dpkg_status, $!);
$self->{STATUS} = {};
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
simplest standard constructor for a singleton
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# LXC default configuration read for default network configuration; this is
# only variable for the unit tests:
our $_system_default = '/etc/lxc/default.conf';
sub new($)
{
unless (defined $singleton)
{
local $_ = shift;
$singleton =
{
SYSTEM_COMMON => '/usr/share/lxc/config/common.conf',
SYSTEM_DEFAULT => $_system_default,
};
bless $singleton, $_;
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_audio_packages> - return package configuration for audio
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_audio_packages>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_audio_packages($)
{
_check_singleton(shift);
my @output =
('# list of mandatory packages needed for audio',
'# See 30-PKG-default.packages for more explanations.');
local $_;
foreach (qw(pactl))
{
my $exec = App::LXC::Container::Data::find_executable($_);
if ($exec)
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_device_default> - return default device configuration
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_device_default>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_device_default($)
{
my $self = _check_singleton(shift);
my @output = ('# changes to ' . $self->{SYSTEM_COMMON} . ':',
'',
'# lxc.autodev = 1 # The default should be sufficient!',
'lxc.pty.max = 8',
'lxc.mount.auto = cgroup:ro proc:mixed sys:ro');
return @output
}
#########################################################################
=head2 B<content_default_filter> - return default filter
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_default_filter>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_default_filter($)
{
use constant POSSIBLE_LINKS =>
qw(/bin /lib /lib32 /lib64 /libx32 /libx64 /sbin);
_check_singleton(shift);
my @head =
('# The filter contains paths that are always ignored (excluded) when',
'# considering mount-points derived from packages. But there are',
'# still some specials possible, the paths may be followed (after some',
'# white-spaces) by one of the following keywords:',
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_default_mounts> - return default mount configuration
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_default_mounts>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_default_mounts($)
{
_check_singleton(shift);
my @output =
('# Some notes to the list of default mounts (mounts that are needed in',
'# every application container):',
'#',
'# 1. Default mounts are read-only bind mounts.',
'# 2. Other mount options must be specified explicitly in field 2.',
'# 3. Special filesystems must be specified explicitly in field 3.',
'#',
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_default_packages> - return default packages
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_default_packages>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_default_packages($)
{
_check_singleton(shift);
local $_;
my @paths = ('/bin/sh');
foreach (qw(ldd ls su))
{
my $exec = App::LXC::Container::Data::find_executable($_);
$exec or fatal('mandatory_package__1_missing', $_);
push @paths, $exec;
}
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_network_default> - return default network configuration
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_network_default>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_network_default($)
{
my $self = _check_singleton(shift);
my $sys_default = $self->{SYSTEM_DEFAULT};
open my $conf, '<', $sys_default
or fatal 'can_t_open__1__2', $sys_default, $!;
my $nr = undef;
my %net = (type => 'veth',
flags => 'up',
link => 'lxcbr0',
'ipv4.address' => '10.0.3.$N/24',
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_network_mounts> - return mount configuration for NETWORK
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_network_mounts>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_network_mounts($)
{
_check_singleton(shift);
my @output =
('# This is an additional mount configuration file for applications with',
'# network access. See 40-MNT-default.mounts for more explanations.',
'',
'# network:',
'/etc/ssl/certs',
'/usr/lib/ssl',
'/usr/share/ca-certificates',
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_network_packages> - return mount configuration for NETWORK
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_network_packages>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_network_packages($)
{
_check_singleton(shift);
my @output =
('# This is an additional packages needed for network access.',
'# See 30-PKG-default.packages for more explanations.');
local $_;
foreach (qw(ip))
{
my $exec = App::LXC::Container::Data::find_executable($_);
if ($exec)
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_x11_mounts> - return mount configuration for X11
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_x11_mounts>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_x11_mounts($)
{
_check_singleton(shift);
my @output =
('# This is an additional mount configuration file for X11 applications.',
'# See 40-MNT-default.mounts for more explanations.',
'',
'# common:',
'/dev/dri create=dir,rw,bind,optional',
'/usr/share/icons',
'/usr/share/mime',
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 B<content_x11_packages> - return package configuration for X11
internal object-oriented implementation of the function
L<App::LXC::Container::Data::content_x11_packages>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_x11_packages($)
{
_check_singleton(shift);
my @output =
('# list of mandatory packages needed for X11',
'# See 30-PKG-default.packages for more explanations.',
'fontconfig-config');
return @output;
}
#########################################################################
=head2 depends_on - find package of file
internal object-oriented implementation of the function
L<App::LXC::Container::Data::depends_on>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub depends_on($$$)
{
my $self = _check_singleton(shift);
}
#########################################################################
=head2 libraries_used - find package of executable
internal object-oriented implementation of the function
L<App::LXC::Container::Data::libraries_used>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub libraries_used($$)
{
_check_singleton(shift);
my ($executable) = @_;
-f $executable or fatal 'internal_error__1', 'not a file: ' . $executable;
# 1st check for non-standard interpreter to avoid security issues (see
# man-page of ldd under "Security"):
open my $file, '-|', 'file', $executable; # Note that file never fails!
my $info = join("\n", <$file>);
close $file;
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
#########################################################################
=head2 package_of - find package of file
internal object-oriented implementation of the function
L<App::LXC::Container::Data::package_of>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub package_of($$)
{
_check_singleton(shift);
my ($file) = @_;
-f $file or fatal 'internal_error__1', 'not a file: ' . $file;
}
#########################################################################
=head2 paths_of - get list of paths of package
internal object-oriented implementation of the function
L<App::LXC::Container::Data::paths_of>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub paths_of($$)
{
_check_singleton(shift);
}
#########################################################################
=head2 regular_users - return list of regular users
internal object-oriented implementation of the function
L<App::LXC::Container::Data::regular_users>
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub regular_users($)
{
_check_singleton(shift);
use constant PWD => '/etc/passwd';
my @users = ();
my $pwd;
# Here I prefer to keep the PWD path hard-coded and not mockable!
# uncoverable branch false
unless (open $pwd, '<', PWD)
{ error 'can_t_open__1__2', PWD, $!; } # uncoverable statement
else
lib/App/LXC/Container/Data/common.pm view on Meta::CPAN
the whole script otherwise.
=head3 returns:
reference to singleton
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _check_singleton($)
{
my $self = shift;
$self == $singleton
or fatal 'wrong_singleton__1__2', ref($self), ref($singleton);
return $self;
}
1;
#########################################################################
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
mount-poins and directories of an LXC application container.
=head3 returns:
the management object
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub new($)
{
my $class = shift;
$class eq __PACKAGE__ or fatal 'bad_call_to__1', __PACKAGE__ . '->new';
debug(2, __PACKAGE__, '::new()');
my $object = {'/' => [NO_MERGE, {}]}; # [ state, sub-directory counters ]
return bless $object, $class;
}
#########################################################################
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
given path.
=head3 returns:
list of implicit mount-lines for path
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub implicit_mount_lines($$)
{
my ($self, $path) = @_;
my @mount_lines = ();
if ($self->mount_point($path) == IMPLICIT)
{
push @mount_lines,
'lxc.mount.entry = ' . $path . ' ' . substr($path, 1) .
' none create=' . (-d $path ? 'dir' : 'file') . ',ro,bind 0 0';
}
local $_;
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
=head3 description:
This method merges all IMPLICIT mount-points gathered so far. The heuristic
limits are the maximum number of children a directory of the corresponding
depth may have as separate mount-points.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub merge_mount_points($$$$$)
{
my ($self, $limit2, $limit3, $limit4, $limit5) = @_;
# merge child mount-points into one mount-point of parent, if reasonable:
local $_;
foreach (sort _depth_sort keys %{$self})
{
next if -f $_; # Existing files can't have children!
# Children of entries with these states never may be merged:
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
=back
=head3 returns:
state of the path
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub mount_point($$;$)
{
my ($self, $path, $state) = @_;
$path =~ s|(?<=.)/+$||; # remove trailing / (just to be on the safe side)
local $_ = $path;
s|/+(?:[^/]+)$||; # Don't resolve link of path itself!
-e $_ and $_ = abs_path($_);
my @parents = ();
while ($_)
{
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
the given path.
=head3 returns:
list of all sub-directories
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub sub_directories($$)
{
my ($self, $path) = @_;
$path =~ s|(?<=.)/+$||; # remove trailing / (just to be on the safe side)
return sort keys %{$self->{$path}[1]};
}
#########################################################################
#########################################################################
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
This method function returns the depth of a given path.
=head3 returns:
depth of path
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _depth_of($)
{
local $_ = $_[0];
return s|[^/]+||g;
}
#########################################################################
=head2 B<_depth_sort> - sort paths depth first
$depth = _depth_sort($path);
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
alphabetic.
=head3 returns:
sort value
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _depth_sort($$)
{
_depth_of($_[1]) <=> _depth_of($_[0]) || $_[0] cmp $_[1]
}
#########################################################################
=head2 B<_set> - set values for a specific path
$self->_set($path, $state, \@parents, $parent_state);
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
=head3 description:
This method function sets the state for a path and its parents. It also
creates the internal directory tree, if necessary.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _set($$$$$)
{
my ($self, $path, $state, $parents, $parent_state) = @_;
defined $self->{$path} or $self->{$path} = [undef, {}];
$self->{$path}[0] = $state;
my $child = $path;
local $_;
foreach (@$parents)
{
defined $self->{$_} or $self->{$_} = [UNDEFINED, {}];
if ($self->{$_}[0] == UNDEFINED)
lib/App/LXC/Container/Run.pm view on Meta::CPAN
programs.
=head3 returns:
the configuration object for the application container
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub new($$$$@)
{
my $class = shift;
$class eq __PACKAGE__ or fatal 'bad_call_to__1', __PACKAGE__ . '->new';
debug(1, __PACKAGE__, '::new("', join('", "', @_), '")');
my $container = shift;
my $user = shift;
my $dir = shift;
my %configuration = (audio => '-',
command => [@_],
lib/App/LXC/Container/Run.pm view on Meta::CPAN
This method runs the container or attaches to it, if it's already running.
In addition it creates the container's start-up script C</lxc-run.sh>, if
one is needed. It also sets up the C<L<nft>> packet filtering if a local
network is required.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub main($)
{
my $self = shift;
debug(1, __PACKAGE__, '::main($self)');
$self->_check_running();
$self->{network_type} eq 'L' and $self->_local_net();
$self->_write_init_sh();
# TODO: Do we need account files when only using root?
# $self->{user} ne 'root' and
$self->_prepare_user();
$self->_run();
lib/App/LXC/Container/Run.pm view on Meta::CPAN
$self->_check_running();
=head3 description:
This method checks if the container is already running (and we just need to
attach to run a second application).
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _check_running($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_check_running($self)');
# check running containers:
open my $lxcls, '-|', 'lxc-ls'
or fatal('call_failed__1__2', 'lxc-ls', $?);
my $containers = join(' ', '', <$lxcls>, '');
close $lxcls or fatal('call_failed__1__2', 'lxc-ls', $?);
local $_ = $self->{name};
lib/App/LXC/Container/Run.pm view on Meta::CPAN
$self->_local_net();
=head3 description:
This method checks the nft packet filtering of the host and adds the filter
for the local network, if it's not already in place.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _local_net($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_local_net($self)');
local $_;
use constant NFT_LIST => (qw(nft list ruleset inet));
use constant NFT_CHAIN => (qw(nft add chain inet lxc localfilter));
use constant NFT_JUMP =>
(qw(nft insert rule inet lxc forward jump localfilter));
use constant NFT_IP =>
lib/App/LXC/Container/Run.pm view on Meta::CPAN
This method prepares the container to be able to switch to the selected user
by creating minimal C</etc/passwd> / C</etc/shadow> and C</etc/group> /
C</etc/gshadow> files for the user, unless the ones from the host are used.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
our $_root_etc = '/etc/'; # variable for unit tests only
sub _prepare_user($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_prepare_user($self)');
if ($self->{mounts}{'/etc'})
{ debug(3, 'using user/groups from host (/etc)'); }
else
{
use constant ACCOUNT_FILES => (qw(group gshadow passwd shadow));
use constant ACCOUNT_FILES_STR => join(' ', ACCOUNT_FILES);
lib/App/LXC/Container/Run.pm view on Meta::CPAN
=head3 description:
This method attaches to the container, if it's already running. Otherwise
it starts it. In either case it runs the previously (C<L<_write_init_sh>>)
created initialisation script C</lxc-run.sh> inside of it.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _run($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_run($self)');
if ($self->{running})
{
# system instead of exec as Devel::Cover has problems with exec
debug(3, 'attaching LXC application container ', $self->{name});
0 == system(
'lxc-attach', '--rcfile', $self->{rc},
lib/App/LXC/Container/Run.pm view on Meta::CPAN
=head3 description:
This method writes the startup script C</lxc-run.sh>. It is used when the
container is started or attached to set up the initial configuration of the
container and to run the requested command (or the interactive shell
C</bin/sh>, if none is specified).
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _write_init_sh($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_write_init_sh($self)');
use constant SHELL => '/bin/sh';
my @todo = ('#!' . SHELL);
if ($self->{running})
{
push @todo, '', '# PipeWire / PulseAudio:',
lib/App/LXC/Container/Run.pm view on Meta::CPAN
is run (including attached) for. It is used when the container is started
or attached and an X11 display using the environment variable C<XAUTHORITY>
exists (within C<_write_init_sh> above). The method returns the path to the
created X11 authority file as it is used inside of the container.
Note that each user needs its own writable directory for the lock-file.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _write_xauthority($$)
{
my ($self, $display) = @_;
debug(4, __PACKAGE__, '::_write_xauthority($self)');
local $_ = '/.xauth-' . $self->{user};
my $container_path = $_ . '/.Xauthority';
my $xauth_dir = $self->{root} . $_;
-d $xauth_dir
or mkdir $xauth_dir, 0700
or fatal('can_t_create__1__2', $xauth_dir, $!);
my $xauth = $xauth_dir . '/.Xauthority';
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
minimal container.
=head3 returns:
the configuration object for the application container
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub new($$)
{
my $class = shift;
$class eq __PACKAGE__ or fatal 'bad_call_to__1', __PACKAGE__ . '->new';
local $_ = shift;
debug(1, __PACKAGE__, '::new("', $_, '")');
m/^[A-Za-z][-A-Z_a-z.0-9]+$/ or fatal 'bad_container_name';
my %configuration = (MAIN_UI => UI::Various::Main->new(),
audio => 0,
filter => ['EM /var/log'],
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
=head3 description:
This method creates and runs the actual application window used to create or
modify the configuration of an application container.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub main($)
{
my $self = shift;
debug(1, __PACKAGE__, '::main($self)');
$self->_create_main_window();
$self->{MAIN_UI}->mainloop;
$self->_save_configuration() if $self->{ok};
}
#########################################################################
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
This method opens a file-selection dialog and runs the passed code reference
when the dialog is finished with the C<OK> button. It contains the common
parts for C<L<_add_file|/_add_file - add item(s) to listbox via
file-selection dialog>> and C<L<_add_package|/_add_package - add item(s) to
package listbox via file-selection dialog>> below.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _add_dialog($$$$)
{
my ($self, $title, $directory, $code) = @_;
my $ui_title = UI::Various::Text->new(text => $title,
height => 3,
width => 45,
align => 5);
my $ui_fs =
UI::Various::Compound::FileSelect->new(mode => 2,
directory => $directory,
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
This method opens a file-selection dialog and add the selected files and/or
directories to the given listbox placing the given prefix in front of them.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
our $_initial_file_dir = '/'; # variable for unit tests only
sub _add_file($$$@)
{
my ($self, $title, $prefix, $ui_listbox) = @_;
debug(3, __PACKAGE__, '::_add_file($self, "', $title,
'", "', $prefix, '", $ui_listbox)');
$self->_add_dialog($title,
$_initial_file_dir,
sub{
my $widget = shift;
local $_;
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
=head3 description:
This method opens a file-selection dialog and add all package(s) containing
a library used by the selected executable(s) to the package listbox.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# extracted for testing purposes:
sub __add_library_packages_internal_code($@)
{
my $ui_listbox = shift;
my @files = @_;
my %libraries = ();
local $_;
foreach my $file (@files)
{
if (-f $file)
{
foreach (libraries_used($file))
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
foreach (sort keys %libraries)
{
$_ = package_of($_);
if ($_ and not defined $packages{$_})
{
$ui_listbox->add($_);
$packages{$_} = 1;
}
}
}
sub _add_library_packages($@)
{
my ($self, $ui_listbox) = @_;
debug(3, __PACKAGE__, '::_add_library_packages($self, $ui_listbox)');
$self->_add_dialog(txt('select_files4library_package'),
$_initial_file_dir,
sub{
my $widget = shift;
__add_library_packages_internal_code($ui_listbox,
@_);
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
This method opens a file-selection dialog and add the package(s) containing
the selected files and/or directories to the package listbox.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
our $_initial_pkg_dir = '/usr/bin'; # variable for unit tests only
sub _add_package($@)
{
my ($self, $ui_listbox) = @_;
debug(3, __PACKAGE__, '::($self, $ui_listbox)');
$self->_add_dialog(txt('select_files4package'),
$_initial_pkg_dir,
sub{
my $widget = shift;
my @files = @_;
local $_;
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
$listbox reference to UI element of the listbox
=head3 description:
This method dialog to select one or more users from a list of regular users
and adds them to the users listbox.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _add_user($$$)
{
my ($self, $ui_listbox) = @_;
debug(3, __PACKAGE__, '::($self, $ui_listbox)');
my $title = txt('select_users');
my $ui_title = UI::Various::Text->new(text => $title,
height => 3,
width => 25,
align => 5);
my @users = regular_users();
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
$self->_create_main_window();
=head3 description:
This method creates the main configuration window.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _create_main_window($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_create_main_window($self)');
my $main = $self->{MAIN_UI};
my $max_width = $main->max_width();
my $max_height = $main->max_height();
my $width = ($main->using eq 'PoorTerm'
? $max_width # PoorTerm doesn't use the columns
: int(($max_width - 2) / 3) - 16);
my $height = $max_height - 21 - 3; # Curses needs 3 additional lines
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
window. Note that the called functions get a reference to the listbox
object as 1st parameter.
=head3 returns:
C<L<UI::Various::Box>> object containing listbox, title and controls
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _create_mw_listbox($@)
{
my ($self, $title, $ra_list, $h, $w, $add, $modify, $indirect) = @_;
debug(2, __PACKAGE__, '::_create_mw_listbox($self, "', $title,
'", $ra_list, ', $h, ', ', $w, ', CODE)');
my $bc = 2;
$bc++ if defined $indirect;
$bc++ if defined $modify;
my $wb = int( ($w - 15) / $bc );
my $ui_title = UI::Various::Text->new(text => $title,
width => $w,
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
write array to file>>), or it compares the existing one against the array
and reports differences as warning.
=head3 returns:
-1 if the file does not exist, 0 if it is equal and 1 otherwise
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _create_or_compare($@)
{
my $path = shift;
debug(3, __PACKAGE__, '::_create_or_compare("', $path, '")');
$path =~ m|/| or $path = _ROOT_DIR_ . '/conf/' . $path;
if (-f $path)
{
local $_;
@_ = map { $_ .= "\n" } @_;
my $diff = diff($path, \@_);
if ($diff)
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
$self->_help_dialog();
=head3 description:
This method creates and runs the dialog with the help text.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _help_dialog($)
{
my $self = shift;
debug(3, __PACKAGE__, '::_help_dialog($self)');
my $main = $self->{MAIN_UI};
$main->dialog({title => txt('help')},
UI::Various::Text->new(text => txt('help_text')),
UI::Various::Button->new(text => txt('ok'),
code => sub{ $_[0]->destroy; }));
}
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
=head3 description:
This method opens two file selection dialogues to choose the location of the
toolbox's configuration directory and creates the symbolic link to it in the
user's C<HOME> directory. It also initialises the directory, if it is empty.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _init_config_dir($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_init_config_dir($self)');
# run initial file selection dialogues:
my $dir = $self->_init_fs_dialog(txt('select_configuration_directory'),
_DEFAULT_CONF_DIR);
$dir or exit 0;
$dir =~ s|(?<=[^/])/+$||;
my $root = $self->_init_fs_dialog(txt('select_root_directory'),
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
This method opens a file-selection dialog and runs the passed code reference
when the dialog is finished with the C<OK> button. It contains the common
parts for C<L<_add_file|/_add_file - add item(s) to listbox via
file-selection dialog>> and C<L<_add_package|/_add_package - add item(s) to
package listbox via file-selection dialog>> below.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _init_fs_dialog($$$)
{
my ($self, $title, $directory) = @_;
my $ui_title = UI::Various::Text->new(text => $title,
height => 3,
width => 45,
align => 5);
my $ui_fs =
UI::Various::Compound::FileSelect->new(mode => 0,
directory => $directory,
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
This function translates an entry of the filter listbox in the UI into the
output for the corresponding meta-configuration file.
=head3 returns:
configuration line for passed string
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _mark2filter($)
{
my ($conf_str) = @_;
my $mark = substr($conf_str, 0, 2);
my $file = substr($conf_str, 3);
my %translate =
(CP => 'copy', EM => 'empty', IG => 'ignore', NM => 'nomerge');
local $_ = $file;
if (defined $translate{$mark})
{ $_ = sprintf("%-39s %s", $_, $translate{$mark}); }
else
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
This function translates an entry of the files listbox in the UI into the
output for the corresponding meta-configuration file.
=head3 returns:
configuration line for passed string
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _mark2mount($)
{
my ($conf_str) = @_;
my $mark = substr($conf_str, 0, 2);
my $file = substr($conf_str, 3);
local $_ = $file;
if ($mark eq ' ')
{}
elsif ($mark eq 'RW')
{
$_ = sprintf("%-39s create=%s,rw,bind%s",
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
@alternatives list of alternatives for the radio buttons
=head3 description:
This method opens a dialog with some radio buttons to modify the mode of the
selected file or directory in the given listbox.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _modify_entry($$$@)
{
my $self = shift;
my $title = shift;
my $ui_listbox = shift;
debug(3, __PACKAGE__, '::($self, "', $title, '", $ui_listbox, "',
join('", "', @_), '")');
4 <= @_ and 0 == @_ % 2 or
fatal 'internal_error__1', 'uneven list in _modify_entry';
my $entry = $ui_listbox->selected();
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
$listbox reference to UI element of the listbox
=head3 description:
This method opens a minimal dialog to allow changing an entry of the given
listbox.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _modify_value($$$)
{
my ($self, $ui_listbox) = @_;
my $entry = $ui_listbox->selected();
defined $entry or return;
my $value = $ui_listbox->texts->[$entry];
debug(3, __PACKAGE__, '::($self, "', $value, '")');
my $title = message('modify__1', $value);
my $ui_title = UI::Various::Text->new(text => $title,
height => 3,
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
=head3 description:
This method checks if the current container already has a filter
meta-configuration file and parses its content into the object representing
the container.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_filter($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_filter($self)');
my $path = _ROOT_DIR_ . '/conf/'
. substr($self->{name}, 0, 1) . substr($self->{name}, -1, 1)
. '-NOT-' . $self->{name} . '.filter';
-f $path or return;
open my $file, '<', $path or fatal 'can_t_open__1__2', $path, $!;
my %translate =
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
=head3 description:
This method checks if the current container already has a master
meta-configuration file and parses its content into the object representing
the container.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_master($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_master($self)');
my $path = _ROOT_DIR_ . '/conf/'
. substr($self->{name}, 0, 1) . substr($self->{name}, -1, 1)
. '-CNF-' . $self->{name} . '.master';
-f $path or return;
open my $file, '<', $path or fatal 'can_t_open__1__2', $path, $!;
local $_;
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
=head3 description:
This method checks if the current container already has a mounts
meta-configuration file and parses its content into the object representing
the container.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_mounts($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_mounts($self)');
my $path = _ROOT_DIR_ . '/conf/'
. substr($self->{name}, 0, 1) . substr($self->{name}, -1, 1)
. '-MNT-' . $self->{name} . '.mounts';
-f $path or return;
open my $file, '<', $path or fatal 'can_t_open__1__2', $path, $!;
$self->{mounts} = [];
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
=head3 description:
This method checks if the current container already has a packages
meta-configuration file and parses its content into the object representing
the container.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_packages($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_packages($self)');
my $path = _ROOT_DIR_ . '/conf/'
. substr($self->{name}, 0, 1) . substr($self->{name}, -1, 1)
. '-PKG-' . $self->{name} . '.packages';
-f $path or return;
open my $file, '<', $path or fatal 'can_t_open__1__2', $path, $!;
$self->{packages} = [];
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
$self->_save_configuration();
=head3 description:
This method saves the current meta-configuration.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _save_configuration($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_save_configuration($self)');
local $_;
my $prefix = _ROOT_DIR_ . '/conf';
-d $prefix or fatal('internal_error__1',
'directory missing in _save_configuration');
$prefix .= '/' .
substr($self->{name}, 0, 1) . substr($self->{name}, -1, 1) . '-';
_write_to($prefix . 'CNF-' . $self->{name} . '.master',
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
=head3 description:
This function opens the file at the give path and writes the array of output
lines into it. If the file already exists and is not writable, the function
returns without changing anything. If anything else goes wrong, the
function aborts the whole script.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _write_to($@)
{
my $path = shift;
if (-e $path and not -w $path)
{
warning 'using_existing_protected__1', $path;
return;
}
open my $file, '>', $path or fatal 'can_t_open__1__2', $path, $!;
local $_;
say $file tabify($_) foreach @_;
lib/App/LXC/Container/Texts.pm view on Meta::CPAN
together with the C<@message_data> with sprintf and passes it on to
C<L<croak|Carp>>.
=head3 returns:
never
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub fatal($;@)
{
my $message_id = shift;
local $_ = sprintf(txt($message_id), @_); # using $_ to allow debugging
croak($_);
}
#########################################################################
=head2 B<error> / B<warning> / B<info> - print error / warning / info message
lib/App/LXC/Container/Texts.pm view on Meta::CPAN
together with the C<@message_data> with sprintf and passes it on to
C<L<carp|Carp>> (in case of errors or warnings) or C<L<warn|perlfunc/warn>>
(in case of informational messages).
Note that currently the first two functions only differ semantically. (This
may or may not change in the future.)
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub error($;@) { carp message(@_); }
sub warning($;@) { carp message(@_); }
sub info($;@) { warn message(@_); }
#########################################################################
=head2 B<message> - return formatted message
$string = message($message_id, @message_data);
=head3 example:
$_ = message('can_t_open__1__2', $_, $!);
lib/App/LXC/Container/Texts.pm view on Meta::CPAN
C<$message_id> and C<@message_data>, e.g. to be used within a compound
widget.
=head3 returns:
the formatted message as string
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub message($;@)
{
my $message_id = shift;
local $_ = txt($message_id);
$_ = sprintf($_, @_);
return $_;
}
#########################################################################
=head2 B<debug> - set debugging level or print debugging message
lib/App/LXC/Container/Texts.pm view on Meta::CPAN
C<$message_id> in the text hash of the currently used language and returns
it.
=head3 returns:
looked up string
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub txt($)
{
my ($message_id) = @_;
if (defined $_text->{$message_id} and $_text->{$message_id} ne '')
{
return $_text->{$message_id};
}
# for missing message we try a fallback to English, if possible:
if ($_text ne $_text_en)
{
lib/App/LXC/Container/Texts.pm view on Meta::CPAN
whenever this matches a tabulator position (multiple of 8). It then returns
the modified string.
=head3 returns:
modified string
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub tabify($)
{
my @strings = split /\n/, shift;
local $_;
foreach (@strings)
{
my $l = int(length($_) / 8) * 8;
while ($l > 0)
{
my $tail = substr($_, $l);
$_ = substr($_, 0, $l);
lib/App/LXC/Container/Update.pm view on Meta::CPAN
configurations, see C<_parse> methods for details).
=head3 returns:
the configuration object for the application container
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub new($@)
{
my $class = shift;
$class eq __PACKAGE__ or fatal 'bad_call_to__1', __PACKAGE__ . '->new';
debug(1, __PACKAGE__, '::new("', join('", "', @_), '")');
local $_;
foreach (@_)
{ m/^[A-Za-z][-A-Z_a-z.0-9]+$/ or fatal 'bad_container_name'; }
my %configuration = (audio => 0,
audio_from => '???',
lib/App/LXC/Container/Update.pm view on Meta::CPAN
=head3 description:
This method reads the meta-configuration files for the operating system and
the specified container(s), analysis them and creates the real LXC
application container configuration.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub main($)
{
my $self = shift;
debug(1, __PACKAGE__, '::main($self)');
local $_ = $self->{containers}[0];
if (m/^(?:no-|local-)?network$/)
{
1 == @{$self->{containers}} or fatal 'special_container__1_alone', $_;
m/^local-network$/ and $self->{network} = 1;
m/^network$/ and $self->{network} = 2;
lib/App/LXC/Container/Update.pm view on Meta::CPAN
file.
=head3 returns:
current container's network number
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub network_number($)
{
my $self = shift;
debug(1, __PACKAGE__, '::network_number($self)');
my $container = $self->{name};
unless (defined $self->{networks}{$container})
{
local $_ = _ROOT_DIR_ . '/.networks.lst';
open my $out, '>>', $_ or fatal 'can_t_open__1__2', $_, $!;
$self->{networks}{$container} = $self->{next_network}++;
lib/App/LXC/Container/Update.pm view on Meta::CPAN
=head3 description:
This method (recursively) creates all (real) mount-points below (including)
the given path.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _create_mount_points($$$)
{
my $self = shift;
my ($mounts, $path, $out) = @_;
debug(3, __PACKAGE__,
'::_create_mount_points::($self, "', join('", "', @_), '")');
local $_ = $mounts->mount_point($path);
if ($_ == EMPTY or $_ == EXPLICIT or $_ == IMPLICIT)
{ $self->_make_lxc_path($path); }
elsif ($_ == COPY or $_ == IMPLICIT_LINK)
{
lib/App/LXC/Container/Update.pm view on Meta::CPAN
=head3 description:
This method creates the given path below the containers LXC directory
(usually C</var/lib/lxc/CONTAINER>). The path will have the same
permissions as the original one. If the update is run by root, it will also
have the same ownership as the original one.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _make_lxc_path($$)
{
my ($self, $path) = @_;
debug(4, __PACKAGE__, '::_make_lxc_path($self, "', $path, '")');
local $_ = $path . '/';
s|(?<=.)/+$||; # remove trailing / (just to be on the safe side)
my @paths = ($_);
unshift @paths, $_ while s|/+(?:[^/]+)$|| and $_;
my $root = $self->{root_fs} . '/' . $self->{name};
-d $root or mkdir $root or fatal('can_t_create__1__2', $root, $!);
lib/App/LXC/Container/Update.pm view on Meta::CPAN
This method parses the applicable global special filter meta-configuration
files and those of the chosen container(s) into the configuration object.
Note that in the case of multiple containers the filter configurations are
merged and only the last occurrence of a filter is the one used in the
created LXC configuration file.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_filter($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_filter($self)');
my @special = ('50-default');
foreach my $container (@special, @{$self->{containers}})
{
my $fname = substr($container, 0, 1) . substr($container, -1, 1)
. '-NOT-' . $container . '.filter';
$container =~ m/^\d\d-/ and
lib/App/LXC/Container/Update.pm view on Meta::CPAN
container(s) into the configuration object.
Note that in the case of multiple containers the master configurations are
merged and the least restrictive (e.g. full network access) overrides the
more restrictive ones (e.g. only local network) regardless of their
sequence.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_master($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_master($self)');
foreach my $container (@{$self->{containers}})
{
my $path = _ROOT_DIR_ . '/conf/'
. substr($container, 0, 1) . substr($container, -1, 1)
. '-CNF-' . $container . '.master';
open my $in, '<', $path or fatal 'can_t_open__1__2', $path, $!;
lib/App/LXC/Container/Update.pm view on Meta::CPAN
This method parses the applicable global special mounts meta-configuration
files and those of the chosen container(s) into the configuration object.
Note that in the case of multiple containers the mounts configurations are
merged and only the last occurrence of a mount-point is the one used in the
created LXC configuration file.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_mounts($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_mounts($self)');
my @special = ('40-default');
$self->{network} and push @special, '41-network';
$self->{x11} and push @special, '61-X11';
foreach my $container (@special, @{$self->{containers}})
{
my $source = substr($container, 0, 1) . substr($container, -1, 1)
lib/App/LXC/Container/Update.pm view on Meta::CPAN
This method parses the applicable global packages meta-configuration files
and those of the chosen container(s) into the configuration object.
Note that in the case of multiple containers the packages configurations are
merged and only the first occurrence of a package is the one reported in the
comment of the created LXC configuration file.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_packages($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_packages($self)');
my @special = ('30-default');
$self->{network} and push @special, '31-network';
$self->{x11} and push @special, '60-X11';
$self->{audio} and push @special, '70-audio';
foreach my $container (@special, @{$self->{containers}})
{
lib/App/LXC/Container/Update.pm view on Meta::CPAN
$self->_parse_specials();
=head3 description:
This method parses the container's optional special configuration file(s)
into the configuration object.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_specials($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_specials($self)');
foreach my $container (@{$self->{containers}})
{
my $fname = substr($container, 0, 1) . substr($container, -1, 1)
. '-SPC-' . $container . '.special';
my $path = _ROOT_DIR_ . '/conf/' . $fname;
-f $path or next;
lib/App/LXC/Container/Update.pm view on Meta::CPAN
=head3 description:
This method parses C</etc/passwd> to add the users' home directories to the
list of global mounts.
TODO: better move reading of passwd to new function ...::Data::users_homes
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_users($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_users($self)');
use constant PWD => '/etc/passwd';
my $key = 'container users';
push @{$self->{mount_sources}}, $key;
$self->{mounts_of_source}{$key} = [];
my $re_users =
'^(?:' . join('|', values %{$self->{users}}) . '):.*:(/[^:]+):[^:]+$';
lib/App/LXC/Container/Update.pm view on Meta::CPAN
=head3 description:
This method writes the parsed meta-configuration into the real concrete
LXC configuration file for the selected (command-line) application
container.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _write_lxc_configuration($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_write_lxc_configuration($self)');
use constant HEADER_1 => "\n#################### ";
use constant HEADER_1s => '#################### ';
use constant HEADER_2 => ' ####################';
local $_;
my $container = $self->{name};
t/01-texts.t view on Meta::CPAN
undef,
'switching debugging level does not cause an error';
warning_like
{ debug(1, 'debug 1'); }
qr{^DEBUG\s+debug 1$},
'equal debugging level is recorded (1 <= 1)';
debug(2);
# manual test as Test::Warn does not support warnings with embedded newlines!
sub test_multiline_warning()
{
my $warning = '';
local $SIG{__WARN__} = sub {
$warning = join('', @_);
};
debug(2, "debug 2\nwith extra line");
is($warning, "DEBUG\t debug 2\n\t with extra line\n",
'multiple debugging lines in higher level are correct');
}
test_multiline_warning();
t/02-init.t view on Meta::CPAN
use App::LXC::Container;
use App::LXC::Container::Data::common;
$App::LXC::Container::Data::_os_release =
T_PATH . '/mockup-files/os-release-debian';
$App::LXC::Container::Data::common::_system_default =
T_PATH . '/mockup-files/network-empty.conf';
#########################################################################
# local helper functions:
sub fail_in_sub_perl($$$;$)
{
my ($home_dir, $conf_dir, $input, $call_new) = @_;
return _sub_perl('
BEGIN {
$ENV{HOME} = "' . $home_dir . '";
$ENV{LXC_DEFAULT_CONF_DIR} = "' . $conf_dir . '";
};
use App::LXC::Container;
do("' . T_PATH . '/functions/call_with_stdin.pl");
my $dummy_obj = { MAIN_UI => UI::Various::Main->new() };
t/02-init.t view on Meta::CPAN
_call_with_stdin
(\@input,
sub {
App::LXC::Container::Setup' .
($call_new
? '->new("dummy");'
: '::_init_config_dir($dummy_obj);') .
'});');
}
sub check_config_file($$$&$)
{
my ($name, $file, $size, $src_func, $re_content) = @_;
ok(-f $file, $name . ' exist');
ok(-s $file > $size, $name . ' is not empty');
if ($src_func)
{
my @content = &$src_func();
local $_ =
App::LXC::Container::Setup::_create_or_compare($file, @content);
is($_, 0, $name . ' is deterministic');
t/03-setup.t view on Meta::CPAN
use App::LXC::Container;
# directory of mockup commands:
$ENV{PATH} = T_PATH . '/mockup:' . $ENV{PATH};
$App::LXC::Container::Data::_os_release =
T_PATH . '/mockup-files/os-release-debian';
#########################################################################
# local helper functions:
sub fail_in_sub_perl($)
{
my ($variant) = @_;
if ($variant == 1)
{
return _sub_perl('
BEGIN { $ENV{LXC_DEFAULT_CONF_DIR} = "' . BAD_CONF . '"; };
use App::LXC::Container;
App::LXC::Container::setup("test");');
}
return _sub_perl('
BEGIN { $ENV{LXC_DEFAULT_CONF_DIR} = "' . BAD_CONF . '"; };
use App::LXC::Container;
App::LXC::Container::Setup::_save_configuration(undef);');
}
sub check_config_against_regexp($$$)
{
my ($name, $nr, $re_content) = @_;
my $file = CONF_ROOT . '/conf/' . $name;
ok(-f $file, $name . ' exists after ' . $nr . ' run');
if (-f $file)
{
open my $content, '<', $file;
local $_ = join('', <$content>);
close $content;
SKIP:{
t/03-setup.t view on Meta::CPAN
eval { App::LXC::Container::Setup::_modify_entry(1,2,3, 1,2); };
like($@,
qr/^INTERNAL ERROR [^:]+: uneven list in _modify_entry$re_msg_tail/,
'short parameter list for _modify_entry fails');
eval { App::LXC::Container::Setup::_modify_entry(1,2,3, 1,2,3,4,5); };
like($@,
qr/^INTERNAL ERROR [^:]+: uneven list in _modify_entry$re_msg_tail/,
'uneven parameter list for _modify_entry fails');
my $dummy_obj = {name => 'not-accessible'};
sub test_not_accessible($)
{
my ($file) = @_;
my $short_path = '/lxc/conf/' . $file;
_remove_file($short_path);
_setup_file($short_path);
_chmod(0, $short_path);
my $re = "can't open '" . LXC_LINK . '/conf/' . $file . "'" . ': .*'
. $re_msg_tail_eval;
(my $func = $file) =~ s/^.*\.//;
$func = 'App::LXC::Container::Setup::_parse_' . $func . '($dummy_obj);';
eval "$func";
like($@, qr/^$re$/,
'reading non-accessible configuration file ' . $file . ' fails');
}
test_not_accessible('ne-NOT-not-accessible.filter');
test_not_accessible('ne-CNF-not-accessible.master');
test_not_accessible('ne-MNT-not-accessible.mounts');
test_not_accessible('ne-PKG-not-accessible.packages');
$dummy_obj = {name => 'bad'};
sub test_bad_config($@)
{
my $file = shift;
my $short_path = '/lxc/conf/' . $file;
_remove_file($short_path);
_setup_file($short_path, @_);
my $re = "ignoring unknown configuration item in '" . LXC_LINK .
'/conf/' . $file . "'" . ', line 1' . $re_msg_tail_eval;
(my $func = $file) =~ s/^.*\.//;
$func = 'App::LXC::Container::Setup::_parse_' . $func . '($dummy_obj);';
output_like
t/03-setup.t view on Meta::CPAN
'valid optional device directory');
like(App::LXC::Container::Setup::_mark2mount('RW /dev/somedevice'),
qr{^/dev/somedevice\s+create=file,rw,bind,optional$},
'valid optional device file');
like(App::LXC::Container::Setup::_mark2mount('OV /'),
qr{^/\s+create=dir,rw\s+tmpfs$},
'valid temporary directory');
#########################################################################
# run tests with other maximum screen sizes:
sub test_other_screen_size($$)
{
my ($w, $h) = @_;
my %dummy_obj = (MAIN_UI => UI::Various::Main->new(),
name => 'x', packages => [], mounts => [], filter => [],
network => 0, x11 => 0, audio => 0, users => []);
# Unfortunately we need to access UI::Various internal structure here to
# modify the maximum size of the virtual screen:
$dummy_obj{MAIN_UI}{max_width} = $w;
$dummy_obj{MAIN_UI}{max_height} = $h;
return bless \%dummy_obj, 'App::LXC::Container::Setup';
t/03-setup.t view on Meta::CPAN
#########################################################################
# special tests for library dependencies (ldd):
package Dummy::UI
{
require Exporter;
our @ISA = qw(Exporter);
sub new($) { my $self = {}; bless $self, 'Dummy::UI'; }
sub add($@) { shift; print "ADD2UI\t", join(',', @_), "\n"; }
};
sub test_ldd_dummy_object(@)
{
my $dummy_ui = Dummy::UI->new();
App::LXC::Container::Setup::__add_library_packages_internal_code
($dummy_ui, @_);
}
stdout_like
{ test_ldd_dummy_object('/bin/ls'); }
qr{^ADD2UI\s+libc6(?::amd64|:i386)?$},
'test for existing library dependencies';
t/05-mounts.t view on Meta::CPAN
is($obj->mount_point('/var/log/cups'), EMPTY,
'got correct state for entry of /var/log/cups');
is($obj->mount_point('/var/log'), EMPTY,
'got correct modified state for entry of /var/log');
#########################################################################
# testing merges in artificial tree:
my $obj2 = App::LXC::Container::Mounts->new();
sub build_tree($$);
sub build_tree($$)
{
my ($down, $root) = @_;
if ($down-- > 0)
{
is($obj2->mount_point($root . '/sub1', UNDEFINED), UNDEFINED,
'correct state could be set for ' . $root . '/sub1');
is($obj2->mount_point($root . '/sub2', UNDEFINED), UNDEFINED,
'correct state could be set for ' . $root . '/sub2');
build_tree($down, $root . '/sub1');
build_tree($down, $root . '/sub2');
t/06-update.t view on Meta::CPAN
use App::LXC::Container::Data;
use App::LXC::Container::Data::Debian;
$App::LXC::Container::Data::Debian::_dpkg_status =
T_PATH . '/mockup-files/dpkg.status';
$App::LXC::Container::Data::_os_release =
T_PATH . '/mockup-files/os-release-debian';
#########################################################################
# local helper functions:
sub fail_in_sub_perl($$)
{
if ($_[0] == 1)
{
return _sub_perl('
use App::LXC::Container;
App::LXC::Container::update("' . $_[1] . '");');
}
elsif ($_[0] == 2)
{
return _sub_perl('
use App::LXC::Container;
$_ = App::LXC::Container::Update->new("' . $_[1] . '");
$_->network_number();');
}
}
my $update_object;
sub obj_keys_in_range($$$$)
{
my ($key, $from, $to, $text) = @_;
local $_ = scalar(keys(%{$update_object->{$key}}));
ok($from <= $_ && $_ <= $to,
$text . "\t(" . $from . ' <= ' . $_ . ' <= ' . $to . ')');
}
sub patch_config($@)
{
my $file = shift;
my $fh;
open $fh, '<', $file or die "can't open ", $file, ': ', $!;
my @content = <$fh>;
close $fh;
local $_;
while (@_)
{
if ($_[0] eq 'd')
use App::LXC::Container;
# directory of mockup commands:
my $test_path = $ENV{PATH} = T_PATH . '/mockup:' . $ENV{PATH};
$App::LXC::Container::Data::_os_release =
T_PATH . '/mockup-files/os-release-debian';
#########################################################################
# local helper functions:
sub fail_in_sub_perl($$)
{
if ($_[0] == 1)
{
return _sub_perl('
use App::LXC::Container;
App::LXC::Container::run("' . $_[1] . '");');
}
else
{ die 'bad branch'; }
}
sub check_config_object($$$)
{
my ($obj, $id, $ra_checks) = @_;
local $_;
is(ref($obj), 'App::LXC::Container::Run', $id . ' returned correct object');
foreach (@$ra_checks)
{
if (ref($_->[1]) eq 'ARRAY')
{
is_deeply($obj->{$_->[0]}, $_->[1],
$id . ' has correct ' . $_->[0] . ' HASH');
}
elsif ($_->[1] =~ m/^\^/)
{
like($obj->{$_->[0]}, qr{$_->[1]}, $id . ' has correct ' . $_->[0]);
}
else
{ is($obj->{$_->[0]}, $_->[1], $id . ' has correct ' . $_->[0]); }
}
}
sub check_config_file($$)
{
my ($file, $rh_checks) = @_;
(my $short = $file) =~ s|^.*/||;
ok(-f $file, $short . ' exists');
open my $in, '<', $file or die "can't open $file: $!";
my $content = join('', <$in>);
local $_;
foreach (sort keys %$rh_checks)
{
my $re = $rh_checks->{$_};
t/08-data.t view on Meta::CPAN
$ENV{UI} = 'PoorTerm'; # PoorTerm allows easy testing
}
use App::LXC::Container::Data;
$App::LXC::Container::Data::_os_release =
T_PATH . '/mockup-files/os-release-debian';
#########################################################################
# local helper functions:
sub check_singleton($$)
{
my ($mockup, $expected) = @_;
$mockup = T_PATH . '/mockup-files/' . $mockup;
$_ = _sub_perl('
use App::LXC::Container::Data;
$App::LXC::Container::Data::_os_release = "' . $mockup . '";
$_ = App::LXC::Container::Data::_singleton();
defined $_ and print $_->{OS};');
if ($expected =~ m/^(\(\?\^u:)?\^/)
{
like($_, qr/^$expected$/,
'singleton output matched m/' . substr($expected, 5, 19) . '/...');
}
else
{ is($_, $expected, "singleton returned expected '$expected'"); }
}
# reset _dpkg_status and depends_on for use with new (mocked) dpkg status file:
sub reset_dpkg_status($)
{
App::LXC::Container::Data::_singleton->{STATUS} = undef;
$App::LXC::Container::Data::Debian::_dpkg_status = $_[0];
}
sub check_comment_only_output($$@)
{
my $function = shift;
my $n = shift;
local $_ = @_;
is($_, $n, $function . ' returned correct number of output lines: ' . $_);
$n = 0;
like($_, qr{^#}, $function . ' returned a comment as line ' . ++$n)
foreach @_;
}
t/functions/call_with_stdin.pl view on Meta::CPAN
#!/bin/false
# not to be used stand-alone
#
# helper function to reassign STDIN:
sub _call_with_stdin($$)
{
my ($stdin_text, $function) = @_;
my $orgin = undef;
open $orgin, '<&', \*STDIN or die "can't duplicate STDIN\n";
close STDIN;
$stdin_text = join("\n", @$stdin_text, '') if ref($stdin_text) eq 'ARRAY';
open STDIN, '<', \$stdin_text or die "can't reassign STDIN\n";
&$function();
close STDIN;
open STDIN, '<&', $orgin or die "can't restore STDIN\n";
t/functions/files_directories.pl view on Meta::CPAN
#!/bin/false
# not to be used stand-alone
#
# helper function to setup test-files and -directories:
sub _chmod($$)
{
my $mode = shift;
while (local $_ = shift)
{
$_ = TMP_PATH . $_;
chmod $mode, $_ or die "can't chmod $mode $_: $!";
}
}
sub _remove_dir($)
{
my $dir = shift;
if (-e $dir)
{ rmdir $dir or die "can't rmdir $dir: $!"; }
}
sub _remove_file($)
{
local $_ = shift;
$_ = TMP_PATH . $_;
if (-e)
{ unlink $_ or die "can't unlink $_: $!"; }
}
sub _remove_link($)
{
my ($sym_link) = @_;
not -l $sym_link or unlink $sym_link or die "can't unlink $sym_link: $!";
}
sub _setup_dir($)
{
local $_ = shift;
$_ = TMP_PATH . $_;
-d or mkdir $_ or die "can't mkdir $_: $!";
}
sub _setup_file($;@)
{
my $file = shift;
$file = TMP_PATH . $file;
unless (-f $file)
{
open my $fh, '>', $file or die "can't create $file: $!";
local $_;
say $fh $_ foreach @_;
close $fh;
}
}
sub _setup_link($$)
{
my ($sym_link, $dest) = @_;
_remove_link($sym_link);
symlink $dest, $sym_link or die "can't link $sym_link to $dest: $!";
}
1;
t/functions/sub_perl.pl view on Meta::CPAN
# string as command:
# see https://stackoverflow.com/questions/56856646/how-do-i-collect-coverage-from-child-processes-when-running-cover-test-and-n
my $under_cover = defined(eval('$Devel::Cover::VERSION'));
note('running with' . ($under_cover ? '' : 'out') .' Devel::Cover');
my $run_perl = $^X;
$under_cover and $run_perl .= ' -MDevel::Cover=-silent,1';
$ENV{PERL5LIB} = join(':', @INC);
sub _sub_perl($)
{
local $_ = $_[0];
$_ = `$run_perl -e '$_' 2>&1`;
return $_;
}
1;
( run in 0.999 second using v1.01-cache-2.11-cpan-65fba6d93b7 )