view release on metacpan or  search on metacpan

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

	 '# Debian:',
	 '/etc/debian_version');
    return @output
}

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

=head2 depends_on - find package of file

    internal object-oriented implementation of the function
    L<App::LXC::Container::Data::depends_on>

=cut

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub depends_on($$$)
{
    my ($self, $package, $include) = @_;
    $self->SUPER::depends_on($package, $include);

    return ()  unless  $self->_dpkg_status($package);
    my @packages = ();
    local $_;
    # outer loop over all possible dependencies:
    my @check = ('pre-depends', 'depends');
    $include > 0  and  push @check, 'recommends';
    $include > 1  and  push @check, 'suggests';
    foreach (@check)
    {
	# inner loop over all possible dependencies:
	foreach ($self->_dpkg_status($package, $_))
	{
	    # only add installed dependencies:
	    push @packages, $_  if  $self->_dpkg_status($_);
	}
    }
    return @packages;
}

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

=head2 package_of - find package of file

    internal object-oriented implementation of the function
    L<App::LXC::Container::Data::package_of>

=cut

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
use constant SEARCH => 'dpkg-query --search ';
sub package_of($$)
{
    my ($self, $file) = @_;
    $self->SUPER::package_of($file);
    local $_;
    # TODO: looks like pipe with redirection in shell never fails:
    # uncoverable branch true
    open my $dpkg, '-|', SEARCH . $file . ' 2>/dev/null'
	or  fatal('internal_error__1',
		  'error calling ' . SEARCH . $file . ': '. $!);
    # escape special characters in file name:
    $file =~ s/([]+*?{}[])/\\$1/;
    my $package = undef;
    while (<$dpkg>)
    {
	if (m/^([^ ]+): $file$/)
	{
	    $package = $1;
	    last;
	}
    }
    close $dpkg;
    return $package;
}

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

=head2 paths_of - get list of paths of package

    internal object-oriented implementation of the function
    L<App::LXC::Container::Data::paths_of>

=cut

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
use constant LISTFILES => 'dpkg-query --listfiles ';
sub paths_of($$)
{
    my ($self, $package) = @_;
    $self->SUPER::paths_of($package);
    local $_;
    # TODO: Better approach to get main architecture?
    foreach ('', ':amd64', ':i386')
    {
	my $pa = $package . $_;
	# TODO: as above:
	# uncoverable branch true
	open my $dpkg, '-|', LISTFILES . $pa . ' 2>/dev/null'
	    or  fatal('internal_error__1',
		      'error calling ' . LISTFILES . $pa . ': '. $!);
	# dpkg returns absolute paths, so we don't have to unify them here:
	my @paths = ();
	foreach (<$dpkg>)
	{
	    s/\r?\n//;
	    # ignore non-existing "package diverts others to:"
	    if (s/^package diverts others to: //)
	    {   next unless -e $_;   }
	    # ignore non-existing "diverted by ... to:"
	    elsif (s/^diverted by [-\w]+ to: //)
	    {   next unless -e $_;   }
	    elsif (m/: /)
	    {
		fatal('internal_error__1',
		      'unexpected content in ' . LISTFILES . $pa . ': '. $_);
	    }
	    push @paths, $_;
	}
	# try explicit architectures if close returns non-null:
	close $dpkg  and  return @paths;
    }