view release on metacpan or  search on metacpan

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

    $self               should be reference to singleton
    $package            name of package
    $key                information to be returned

=head3 description:

Read and cache dependency information from the dpkg status file.  A call
without key can be used to check if a package is installed, otherwise the
allowed keys are C<depends>, C<recommends> and C<suggests>.

=head3 returns:

    requested information

=cut

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

# List of installed packages, their dependencies and other information; this
# is only variable for the unit tests:
our $_dpkg_status = '/var/lib/dpkg/status';

sub _dpkg_status($$;$)
{
    my ($self, $package, $key) = @_;

    # parse and cache file if called for 1st time:
    unless (defined $self->{STATUS})
    {
	my ($pkg, $stat) = ('');
	open $stat, '<', $_dpkg_status
	    or  fatal('can_t_open__1__2', $_dpkg_status, $!);
	$self->{STATUS} = {};
	local $_;
	while (<$stat>)
	{
	    if (m/^Package: (\S+)$/)
	    {
		$pkg = $1;
		defined $self->{STATUS}{$pkg}
		    or  $self->{STATUS}{$pkg} = {};
	    }
	    elsif (m/^Architecture: (\S+)$/)
	    {
		$pkg  or
		    fatal('can_t_determine_package_in__1__2', $_dpkg_status, $.);
		defined $self->{STATUS}{$pkg}{arch}
		    or  $self->{STATUS}{$pkg}{arch} = [];
		push @{$self->{STATUS}{$pkg}{arch}}, lc($1);
	    }
	    elsif (m/^$/)
	    {	$pkg = '';   }
	    elsif (m/^(Depends|Pre-Depends|Recommends|Suggests): (.*)$/)
	    {
		$pkg  or
		    fatal('can_t_determine_package_in__1__2', $_dpkg_status, $.);
		my $key = lc($1);
		my @dependencies =
		    map { s/ \([<=>]+ [^)]+\)$//; $_ }
		    split m/(?:, | \| )/, $2;
		$self->{STATUS}{$pkg}{$key} = \@dependencies;
	    }
	}
	close $stat;
    }

    return undef	unless  defined $self->{STATUS}{$package};
    return 1		unless  defined $key;
    return ()		unless  defined $self->{STATUS}{$package}{$key};
    return @{$self->{STATUS}{$package}{$key}};
}

1;

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

=head1 SEE ALSO

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

=head1 LICENSE

Copyright (C) Thomas Dorner.

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.  See LICENSE file for more details.

=head1 AUTHOR

Thomas Dorner E<lt>dorner (at) cpan (dot) orgE<gt>

=cut