view release on metacpan or  search on metacpan

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

    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

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_filter($)