view release on metacpan or  search on metacpan

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

    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

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
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
	    $fname = (substr($container, 0, 2) . '-NOT-' .
		      substr($container, 3) . '.filter');
	my $path = _ROOT_DIR_ . '/conf/' . $fname;
	open my $in, '<', $path  or  fatal 'can_t_open__1__2', $path, $!;
	local $_;

	while (<$in>)
	{
	    next if m/^\s*(?:#|$)/;
	    s/\s*#.*$//;
	    if (m{^\s*(/\S+)\s+(copy|empty|ignore|nomerge)\s*$})
	    {	$self->{filter}{$1} = $2;   }
	    else
	    {	error 'ignoring_unknown_item_in__1__2', $path, $.;   }
	}
	close $in;
    }
}

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

=head2 B<_parse_master> - parse master configuration file(s)

    $self->_parse_master();

=head3 description:

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

	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;
    my $include = 0;		# TODO: Get initial value via interface!
    while (@packages)
    {
	my @add = ();
	foreach (@packages)
	{   push @add, depends_on($_, $include);   }
	@packages = ();
	$include = -1;
	foreach (@add)
	{
	    unless (defined $referenced_packages{$_})
	    {
		$referenced_packages{$_} = 0;
		push @packages, $_;
	    }