App-LXC-Container
view release on metacpan or search on metacpan
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
use App::LXC::Container::Mounts;
my $mounts = App::LXC::Container::Mounts->new();
$mounts->mount_point($path, EXPLICIT);
if ($mounts->mount_point($path) == IMPLICIT) { ... }
$mounts->mount_point($path, REMOVE);
$mounts->merge_mount_points(12);
... foreach $mounts->sub_directories($path);
say $out $_ foreach $mounts->implicit_mount_lines('/');
$mounts->create_mount_points('/');
=head1 ABSTRACT
This module is used by L<App::LXC::Container::Update> to manage the
(possible) mount-points of a container that is updated.
=head1 DESCRIPTION
The module handles all kinds of mount-points of an LXC container
lib/App/LXC/Container/Mounts.pm view on Meta::CPAN
debug(2, __PACKAGE__, '::new()');
my $object = {'/' => [NO_MERGE, {}]}; # [ state, sub-directory counters ]
return bless $object, $class;
}
#########################################################################
=head2 B<implicit_mount_lines> - get list of implicit mount-lines for path
say $out $_ foreach $mounts->implicit_mount_lines('/');
=head3 parameters:
$path root path
=head3 description:
This method (recursively) returns a list of mount-lines for the LXC
configuration. It returns all implicit mount-points below (including) the
given path.
lib/App/LXC/Container/Run.pm view on Meta::CPAN
}
}
else
{ unshift @command, "'$cmd'"; }
debug(4, 'command is "exec', join(' ', @command), '"');
push @todo, join(' ', 'exec', @command);
# finally write startup script:
open my $f, '>', $self->{init}
or fatal 'can_t_open__1__2', $self->{init}, $!;
say $f $_ foreach @todo;
close $f;
# A failing chmod can only happen in very unlikely race conditions:
# uncoverable branch true
unless (chmod(0755, $self->{init}) == 1)
{
# uncoverable statement
fatal 'call_failed__1__2', 'chmod', $self->{init};
}
# TODO: We could optimise everything if we only have /bin/sh as single
# command (no script needed)!
lib/App/LXC/Container/Setup.pm view on Meta::CPAN
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 @_;
close $file;
}
#########################################################################
1;
#########################################################################
#########################################################################
lib/App/LXC/Container/Update.pm view on Meta::CPAN
{
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}++;
say $out $self->{networks}{$container}, ':', $container;
close $out;
}
return $self->{networks}{$container};
}
#########################################################################
#########################################################################
=head1 HELPER METHODS
lib/App/LXC/Container/Update.pm view on Meta::CPAN
use constant HEADER_1s => '#################### ';
use constant HEADER_2 => ' ####################';
local $_;
my $container = $self->{name};
my $path = _ROOT_DIR_ . '/' . $container . '.conf';
open my $out, '>', $path or fatal 'can_t_open__1__2', $path, $!;
################################
# part 1 - global definitions:
say $out '# container description created by ', __PACKAGE__;
say($out
'# MASTER: ',
($self->{network} == 2 ? 'G' . $self->network_number() :
$self->{network} == 1 ? 'L' . $self->network_number() : 'N'),
',', ($self->{x11} ? 'X' : '-'),
',', ($self->{audio} ? 'A' : '-'));
say $out 'lxc.uts.name = ' . $container;
say $out 'lxc.rootfs.path = ' . $self->{root_fs} . '/' . $container;
say $out 'lxc.rootfs.options = idmap=container';
if ($self->{network})
{
say $out
HEADER_1, $self->{network_from}, ', 10-NET-default.conf', HEADER_2;
$_ = _ROOT_DIR_ . '/conf/10-NET-default.conf';
open my $in, '<', $_ or fatal 'can_t_open__1__2', $_, $!;
my $network_number = $self->network_number();
while (<$in>)
{
next if m/^\s*(?:#|$)/;
s|\.\$N/|.$network_number/|;
print $out $_;
}
close $in;
}
else
{
say $out HEADER_1, 'no network', HEADER_2;
say $out 'lxc.net.0.type = empty';
}
say $out HEADER_1, '20-DEV-default.conf', HEADER_2;
$_ = _ROOT_DIR_ . '/conf/20-DEV-default.conf';
open my $in, '<', $_ or fatal 'can_t_open__1__2', $_, $!;
while (<$in>)
{ print $out $_ unless m/^\s*(?:#|$)/; }
close $in;
my @users_from = @{$self->{users_from}};
my %groups = ();
if (@users_from)
{
# TODO: This is a workaround while su does not work with a mapped root:
# uncoverable branch false
unless (defined $self->{users}{root})
{
push @{$self->{user_ids}}, 0;
$self->{users}{0} = 'root';
}
say $out HEADER_1, join(', ', @users_from), HEADER_2;
my $uid = 0;
foreach (sort {$a <=> $b} keys %{$self->{users}})
{
say $out 'lxc.idmap = u ', $uid, ' ', 100000 + $uid, ' ', $_ - $uid
if $_ - $uid > 1;
my $user = $self->{users}{$_};
say $out '# ', $user, ':';
say $out 'lxc.idmap = u ', $_, ' ', $_, ' 1';
$uid = $_;
foreach (groups_of($uid))
{
# There are no standard users with multiple groups:
# uncoverable branch false
defined $groups{$_} or $groups{$_} = '';
$groups{$_} .= ' ' . $user;
}
$uid++;
}
say $out 'lxc.idmap = u ', $uid, ' ', 100000 + $uid, ' ', 65536 - $uid;
}
else
{
say $out HEADER_1, '-no privileged users-', HEADER_2;
say $out 'lxc.idmap = u 0 100000 65536';
}
if (0 < keys(%groups))
{
my $gid = 0;
foreach (sort {$a <=> $b} keys %groups)
{
say $out 'lxc.idmap = g ', $gid, ' ', 100000 + $gid, ' ', $_ - $gid
if $_ - $gid > 1;
say $out '#', $groups{$_}, ':';
say $out 'lxc.idmap = g ', $_, ' ', $_, ' 1';
$gid = $_ + 1;
}
say $out 'lxc.idmap = g ', $gid, ' ', 100000 + $gid, ' ', 65536 - $gid;
}
else
{ say $out 'lxc.idmap = g 0 100000 65536'; }
################################
# part 2 - special configuration:
if (@{$self->{specials}})
{
say $out HEADER_1, 'special configuration', HEADER_2;
say $out $_ foreach @{$self->{specials}};
}
################################
# part 3 - explicit mounts:
my $mounts = App::LXC::Container::Mounts->new();
foreach my $source (@{$self->{mount_sources}})
{
say $out HEADER_1, $source, HEADER_2;
foreach (@{$self->{mounts_of_source}{$source}})
{
next unless $self->{mount_source}{$_} eq $source;
say $out 'lxc.mount.entry = ', $self->{mount_entry}{$_};
$mounts->mount_point($_, EXPLICIT);
}
}
################################
# part 4a - implicit mounts (from packages) - determine prerequisites:
print $out "\n";
foreach my $source (@{$self->{package_sources}})
{
say $out HEADER_1s, $source, HEADER_2;
foreach (sort keys %{$self->{package_source}})
{
say $out '# ', $_
if $self->{package_source}{$_} eq $source;
}
}
# We sort packages according to their reference count and put the user
# selections at or near the end (by initialising them with a negative
# reference count):
my @packages = @{$self->{packages}};
my %referenced_packages =
map { ($_, ($self->{package_source}{$_} =~ m/^\d/) ? 0 : -2) }
@packages;
lib/App/LXC/Container/Update.pm view on Meta::CPAN
{
$_ = $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')
lib/App/LXC/Container/Update.pm view on Meta::CPAN
$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, '/');
t/functions/files_directories.pl view on Meta::CPAN
}
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: $!";
}
( run in 0.574 second using v1.01-cache-2.11-cpan-d7a12ab2c7f )