view release on metacpan or  search on metacpan

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

=head1 ABSTRACT

This module provides configuration data specific for Debian.

=head1 DESCRIPTION

see L<App::LXC::Container::Data>

=cut

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

use v5.14;
use strictures;
no indirect 'fatal';
no multidimensional;
use warnings 'once';

our $VERSION = '0.41';

use App::LXC::Container::Data::common;
use App::LXC::Container::Texts;

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

=head1 EXPORT

Nothing is exported as access should only be done using the singleton
object.

=cut

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

require Exporter;
our @ISA = qw(App::LXC::Container::Data::common);
our @EXPORT_OK = qw();

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

=head1 METHODS

=cut

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

=head2 B<content_default_mounts> - return default mount configuration

    Internal Object-oriented implementation of the function
    L<App::LXC::Container::Data::content_default_mounts>

=cut

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub content_default_mounts($$@)
{
    local $_ = shift;
    my @output =
	($_->SUPER::content_default_mounts(@_),
	 '',
	 '# 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;
    }
    fatal('internal_error__1',
	  LISTFILES . 'failed to find anything for ' . $package);
}

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

=head1 INTRNAL METHODS

The following methods may only be used internally:

=cut

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

=head2 B<_dpkg_status> - read and cache dpkg status information

    my $boolean = $self->_dpkg_status($package);
        or
    my @values = $self->_dpkg_status($package, $key);

=head3 example:

    if ($self->_dpkg_status($package))
    {
        my @depends = $self->_dpkg_status($package, 'depends');
        my @recommends = $self->_dpkg_status($package, 'recommends');
        my @suggests = $self->_dpkg_status($package, 'suggests');
    }