view release on metacpan or  search on metacpan

lib/App/LXC/Container/Update.pm  view on Meta::CPAN

	}
	close $in;
    }
    if ($self->{audio}  and  not  $self->{network})
    {	warning('audio_network_only');   }

}

#########################################################################

=head2 B<_parse_mounts> - parse mounts configuration file

    $self->_parse_mounts();

=head3 description:

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)
	    . '-MNT-' . $container . '.mounts';
	$container =~ m/^\d\d-/  and
	    $source = (substr($container, 0, 2) . '-MNT-' .
		       substr($container, 3) . '.mounts');
	my $path = _ROOT_DIR_ . '/conf/' . $source;
	open my $in, '<', $path  or  fatal 'can_t_open__1__2', $path, $!;
	push @{$self->{mount_sources}}, $source;
	$self->{mounts_of_source}{$source} = [];
	local $_;
	while (<$in>)
	{
	    next if m/^\s*(?:#|$)/;
	    s/\s*#.*$//;
	    if (m|^\s*(/\S+)(?:\s+(\S+)(?:\s+(\S+)\s*)?)?$|)
	    {
		my ($path, $options, $fsys) = ($1, $2, $3);
		my $entry = ($fsys
			     ? $fsys . ' ' . substr($path, 1) . ' ' . $fsys
			     : $path . ' ' . substr($path, 1) . ' none');
		$entry .=
		    ' ' .
		    ($options
		     ? $options
		     : 'create=' . (-d $path ? 'dir' : 'file') . ',ro,bind')
		    . ' 0 0';
		$self->{mount_entry}{$path} = $entry;
		$self->{mount_source}{$path} = $source;
		push @{$self->{mounts_of_source}{$source}}, $path;
	    }
	    else
	    {	error 'ignoring_unknown_item_in__1__2', $path, $.;   }
	}
	close $in;
    }
}

#########################################################################

=head2 B<_parse_packages> - parse packages configuration file

    $self->_parse_packages();

=head3 description:

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}})
    {
	my $source = substr($container, 0, 1) . substr($container, -1, 1)
	    . '-PKG-' . $container . '.packages';
	$container =~ m/^\d\d-/  and
	    $source = (substr($container, 0, 2) . '-PKG-' .
		       substr($container, 3) . '.packages');
	my $path = _ROOT_DIR_ . '/conf/' . $source;
	open my $in, '<', $path  or  fatal 'can_t_open__1__2', $path, $!;
	push @{$self->{package_sources}}, $source;
	local $_;
	while (<$in>)
	{
	    next if m/^\s*(?:#|$)/;
	    if (m/^\s*(\S+)\s*(?:#|$)/)
	    {
		unless (defined $self->{package_source}{$1})
		{
		    $self->{package_source}{$1} = $source;
		    push @{$self->{packages}}, $1;
		}

lib/App/LXC/Container/Update.pm  view on Meta::CPAN

{
    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;
	open my $in, '<', $path  or  fatal 'can_t_open__1__2', $path, $!;
	local $_;

	while (<$in>)
	{
	    next if m/^\s*(?:#|$)/;
	    s/\s*#.*$//;
	    s/\r?\n$//;
	    push @{$self->{specials}}, $_;
	}
	close $in;
    }
}

#########################################################################

=head2 B<_parse_users> - add mounts for users' home directories

    $self->_parse_users();

=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}}) . '):.*:(/[^:]+):[^:]+$';
    # Normally this could never fail:
    # uncoverable branch true
    open my $pwd, '<', PWD  or  fatal 'can_t_open__1__2', PWD, $!;
    my @users = ();
    local $_;
    while (<$pwd>)
    {
	next unless m/$re_users/o;
	$self->{mount_entry}{$1} =
	    $1 . ' ' . substr($1, 1) . ' none create=dir,rw,bind';
	$self->{mount_source}{$1} = $key;
	push @{$self->{mounts_of_source}{$key}}, $1;
    }
    close $pwd;
}

#########################################################################

=head2 B<_write_lxc_configuration> - write LXC configuration file

    $self->_write_lxc_configuration();

=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};
    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 $_;