App-LXC-Container
view release on metacpan or search on metacpan
lib/App/LXC/Container/Update.pm view on Meta::CPAN
=head2 B<new> - create configuration object for application container
$configuration = App::LXC::Container::Update->new(@container);
=head3 parameters:
@container name of the container(s) to be configured
=head3 description:
This is the constructor for the object used to transform the
meta-configuration into the real one. It reads all global configuration
files. Note that the name of the last container is the one actually used
for the created configuration (as it's the one overwriting most other
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 => '???',
containers => [ @_ ],
empty_files => [],
filter => {},
mount_entry => {},
mount_source => {},
mount_sources => [],
mounts_of_source => {},
name => $_[-1],
network => 0,
network_from => '???',
networks => {_bridge => 1},
next_network => 2,
package_source => {},
package_sources => [],
packages => [],
root_fs => '/var/lib/lxc',
specials => [],
user_ids => [],
users => {},
users_from => [],
x11 => 0,
x11_from => '???');
my $self = bless \%configuration, $class;
-e _ROOT_DIR_ or fatal 'link_to_root_missing';
-l _ROOT_DIR_ or fatal '_1_is_not_a_symbolic_link' , _ROOT_DIR_;
my $path = _ROOT_DIR_ . '/.networks.lst';
open my $in, '<', $path or fatal 'can_t_open__1__2', $path, $!;
while (<$in>)
{
next if m/^\s*(?:#.*)?$/;
if (m/^(\d+):([-A-Z_a-z.0-9]+)$/)
{ $self->{networks}{$2} = $1; }
else
{ error 'ignoring_unknown_item_in__1__2', $path, $.; }
}
close $in;
foreach (sort {$a <=> $b} values %{$self->{networks}})
{ $self->{next_network}++ if $self->{next_network} == $_; }
$path = _ROOT_DIR_ . '/.root_fs';
open $in, '<', $path or fatal 'can_t_open__1__2', $path, $!;
while (<$in>)
{
if (m|^(/.*)$|)
{ $self->{root_fs} = $1; }
else
{ error 'ignoring_unknown_item_in__1__2', $path, $.; }
}
close $in;
return $self;
}
#########################################################################
=head2 B<main> - transform meta-configuration(s) into real one
$configuration->main();
=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;
$self->{audio_from} = $_;
$self->{network_from} = $_;
$self->{x11_from} = $_;
$self->{containers} = [];
lib/App/LXC/Container/Update.pm view on Meta::CPAN
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)
{
(my $parent = $path) =~ s|/[^/]+$||;
$self->_make_lxc_path($parent);
-d $path and not -l $path
and fatal('internal_error__1', $path.' is directory in COPY');
my $target = $self->{root_fs} . '/' . $self->{name} . $path;
unless (-e $target or -l $target)
{
system('cp', '--archive', $path, $target) == 0
or error('can_t_copy__1__2', $path, $?);
}
}
$self->_create_mount_points($mounts, $_)
foreach $mounts->sub_directories($path);
}
#########################################################################
=head2 B<_make_lxc_path> - create path in LXC directory tree of container
$self->_make_lxc_path($path);
=head3 parameters:
$path the path to be created
=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, $!);
foreach (@paths)
{
-e $_ or fatal('_1_does_not_exist', $path);
my $target = $root . $_;
next if -e $target;
my $stat = stat($_);
my ($mode, $uid, $gid) = ($stat->mode, $stat->uid, $stat->gid);
if (-d)
{
$mode |= 0200; # prevent blocking ourselves later on
if (-l)
{
# links can be arbitrarily deep, so we use make_path on the
# absolute path and hope for no clashes:
$target = $root . abs_path($_);
my $errors = [];
make_path($target, {chmod => $mode, error => \$errors});
$errors = join(' ', map { (values(%$_)) } @$errors);
$errors eq ''
or error('can_t_create__1__2', $target, $errors);
}
else
{
mkdir $target or fatal('can_t_create__1__2', $target, $!);
}
# There are no standard files known to me meeting condition 2 or
# 4 (but not 1 and 3):
# uncoverable condition right
# uncoverable condition right count:3
$uid == 0 or $gid == 0 or $mode & 0001 or $_ eq $path
or warning('_1_may_be_inaccessible', $_);
}
else
{
open my $f, '>', $target
or fatal('can_t_create__1__2', $target, $!);
close $f;
}
if (-W $target)
{
# ignoring errors as mounting overrules most problems anyway:
chmod $mode, $target;
chown $uid, $gid, $target;
}
}
}
#########################################################################
=head2 B<_parse_filter> - parse filter configuration file
$self->_parse_filter();
=head3 description:
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
lib/App/LXC/Container/Update.pm view on Meta::CPAN
@packages = ();
$include = -1;
foreach (@add)
{
unless (defined $referenced_packages{$_})
{
$referenced_packages{$_} = 0;
push @packages, $_;
}
$referenced_packages{$_}++;
}
}
@packages =
sort { $referenced_packages{$b} <=> $referenced_packages{$a} }
keys %referenced_packages;
################################
# part 4b - implicit mounts (from packages) - prepare filters:
my $header = 0;
foreach my $key (sort keys %{$self->{filter}})
{
$_ = $self->{filter}{$key};
if ($_ eq 'copy')
{ $mounts->mount_point($key, COPY); }
elsif ($_ eq 'empty')
{
if (-d $key)
{
unless ($header)
{
say $out HEADER_1, 'empty filters', HEADER_2;
$header = 1;
}
say($out
'lxc.mount.entry = tmpfs ', substr($key, 1),
' tmpfs create=dir,rw 0 0');
$mounts->mount_point($key, EMPTY);
}
else
{ push @{$self->{empty_files}}, $key; }
}
elsif ($_ eq 'ignore')
{ $mounts->mount_point($key, IGNORE); }
elsif ($_ eq 'nomerge')
{ $mounts->mount_point($key, NO_MERGE); }
else
{ fatal 'internal_error__1', 'bad filter value: ' . $_; }
}
################################
# part 4c - implicit mounts (from packages) - gather and merge paths of
# packages (while respecting the filters!):
foreach my $package (@packages)
{
# gather paths of next package:
foreach (paths_of($package))
{
unless (-e)
{
error('_1_does_not_exist', $_);
next;
}
my $state = undef;
if (-l)
{
$state = $mounts->mount_point($_);
$mounts->mount_point($_, IMPLICIT_LINK) if $state == UNDEFINED;
next;
}
next if -d;
$_ = abs_path($_); # resolve links in path!
$state = $mounts->mount_point($_);
if ($state == UNDEFINED)
{ $mounts->mount_point($_, IMPLICIT); }
}
# TODO: tune heuristic, put into constant or make configurable:
$mounts->merge_mount_points(100, 30, 4, 3);
}
################################
# part 4d - implicit mounts (from packages) - write configuration:
say $out HEADER_1, 'mounts derived from above packages', HEADER_2;
say $out $_ foreach $mounts->implicit_mount_lines('/');
################################
# part 5 - create all mount points:
my $errors = [];
$_ = $self->{root_fs} . '/' . $container;
-d $_ and remove_tree($_, {error => \$errors, safe => 1});
$errors = join(' ', map { (values(%$_)) } @$errors);
$errors eq '' or error('can_t_remove__1__2', $_, $errors);
$self->_create_mount_points($mounts, '/');
################################
# part 6 - create all empty files:
foreach (@{$self->{empty_files}})
{
$_ = $self->{root_fs} . '/' . $container . $_;
# As we just deleted the whole tree we can't create a test for a
# failed empty file here:
# uncoverable branch true
open my $empty, '>', $_ or fatal 'can_t_open__1__2', $_, $!;
close $empty;
chmod 0600, $_;
}
close $out;
}
#########################################################################
1;
#########################################################################
#########################################################################
=head1 SEE ALSO
man pages C<lxc.container.conf>, C<lxc> and C<lxcfs>
( run in 1.483 second using v1.01-cache-2.11-cpan-39bf76dae61 )