src/info.pl

#!/usr/bin/env perl
use v5.16;
use strict;
use warnings FATAL => 'all';
use FindBin;
use lib "$FindBin::Bin";
use mplib::config qw($CFG);
use mplib::util qw(fail slot_key);
use mplib::db qw(read_db);
use mplib::version qw(parse_dep_token);
use mplib::portformat qw(parse_pkg_use enabled_use resolve_slot);
use mplib::resolve qw(init find_portdir pkgconf effective_deps held_reason resolved_slotted_deps pconf_lookup with_sysroot_scope);
 
my $flags = mplib::config::parse_flags(\@ARGV);
mplib::config::load($flags);
fail("pkg name required") unless defined $ARGV[0];
init();
 
# a "name:slot" argument (e.g. what "mp slots" itself prints back) needs
# splitting before find_portdir, same as fetch.pl/install_pkg -- passing
# the combined string straight through never matches (find_portdir's
# plain-name scan compares against the bare pkg_name only).
my $tok = parse_dep_token($ARGV[0]);
my $portdir = find_portdir($tok->{name}, $tok->{slot}, $tok->{repo});
fail("port $ARGV[0] not found") unless $portdir;
my $pc = pkgconf($portdir);
my $db = read_db();
# the EFFECTIVE slot (resolve_slot: raw pkg_slot plus any enabled
# pkg_slot_use suffix), not the raw pkg.conf field -- for a USE-driven
# port those can differ, and $canon below must match whatever "mp
# install" would actually resolve to for every lookup that follows
# (held_reason, enabled_use, db status, linkdeps).
my $slot  = resolve_slot($pc, $pc->{pkg_name});
my $canon = slot_key($pc->{pkg_name}, $slot);
 
print "name:      $pc->{pkg_name}\n";
print "slot:      $slot\n" if $slot && $slot ne '0';
if($pc->{pkg_slot_use})
{
	my $en = enabled_use($pc->{pkg_name}, parse_pkg_use($pc->{pkg_use}));
	print "slot_use:  ", join(' ', map {
		my $flag = $_;
		($en->{$flag} ? '*' : ' ') . $flag
	} split ' ', $pc->{pkg_slot_use}), "\n";
}
my $sysroot = pconf_lookup($canon, 'SYSROOT');
if(defined $sysroot && $sysroot ne '')
{
	print "sysroot:   $sysroot\n";
}
print "license:   $pc->{pkg_license}\n";
print "ver:       $pc->{pkg_ver}\n";
print "deps:      ", ($pc->{pkg_deps} ? $pc->{pkg_deps} : '(none)'), "\n";
print "bdepend:   $pc->{pkg_bdepend}\n" if $pc->{pkg_bdepend};
print "rdepend:   $pc->{pkg_rdepend}\n" if $pc->{pkg_rdepend};
if(join(' ', effective_deps($pc, $canon)) ne ($pc->{pkg_deps} || ''))
{
	print "deps(eff): ", join(' ', effective_deps($pc, $canon)), "\n";
}
print "tags:      ", ($pc->{pkg_tags} ? $pc->{pkg_tags} : '(none)'), "\n";
print "pref:      $pc->{pkg_pref}\n";
print "conflicts: ", ($pc->{pkg_conflicts} ? $pc->{pkg_conflicts} : '(none)'), "\n";
print "keywords:  $pc->{pkg_keywords}\n" if $pc->{pkg_keywords};
if($pc->{pkg_use})
{
	my $use = parse_pkg_use($pc->{pkg_use});
	my $en = enabled_use($canon, $use);
	print "use:       ", join(' ', map {
		my $flag = $_;
		my $mark = $en->{$flag} ? '*' : ' ';
		"$mark$flag"
	} sort keys %$use), "\n";
}
# a package routed into a sysroot lives in ITS OWN db, not the default
# one already loaded into $db -- swap into it for these last few lookups
# (mirrors install_pkg/remove_pkg) so info never misreports a
# sysroot-installed package as "not installed".
my $rootdb;
with_sysroot_scope($canon, sub { $rootdb = $_[0]; });
my $statusdb = $rootdb || $db;
 
my @linked = resolved_slotted_deps($pc, $canon, $statusdb);
if(@linked)
{
	print "buildlink: $_\n" for @linked;
}
if(my $why = held_reason($canon))
{
	print "hold:      $why\n";
}
if($statusdb->{$canon})
{
	print "status:    installed ($statusdb->{$canon}{ver})";
	print ", requested" if $statusdb->{$canon}{requested};
	print "\n";
}
else
{
	print "status:    not installed\n";
}