File Coverage

blib/lib/Gentoo/Probe.pm

Criterion	Covered	Total	%
statement	37	155	23.8
branch	11	72	15.2
condition	1	15	6.6
subroutine	9	22	40.9
pod	0	15	0.0
total	58	279	20.7

package Gentoo::Probe;
our ($VERSION) = q(1.0.6);
use strict; $|=1;

sub import { goto \&Exporter::import };
use Gentoo::Util;
use Cwd;
our(@mods);
my (%defs) = (
			'uninstalled'  =>  0,
			'installed'    =>  0,
			'case'         =>  1,
			'versions'     =>  0,
			'builds'       =>  0,
			'verbose'      =>  0,
			'latest'       =>  0,
			'pats'         =>  [],
			'cfgdir'       =>  undef,
			'portdir'      =>  undef,
			'vdb_dir'      =>  undef,
);
my $cfg;
sub cfg {
	$cfg ||= do {
		local $_ = eval q{
			use Gentoo::Config;
			new Gentoo::Config;
		};
		die "$@" if "$@";
		die "no cfg!" unless defined $_;
		$_;
	};
	$cfg;
};
sub output {
	my $self = shift;
	print @_, "\n";
};
sub portdir  {
	$_[0]->{portdir};
};
sub overdir {
	$_[0]->{overdir};
};
sub vdb_dir {
	$_[0]->{vdb_dir};
};
sub new {
	local $_;
	my $class = shift;
	my $passed = @_ ? shift : {};
	confess "usage: new Gentoo::Probe(\%parms) [got: ", $passed, "]"
		unless ref $passed;
	my %data = ( %defs, %{$passed} );
	my $self=\%data;
	bless($self,$class);
	$self->gen_methods();
	for($self->{portdir}) {
		$_= cfg()->get(qw(PORTDIR)) unless defined;
	};
	for($self->{vdb_dir}) {
		$_= cfg()->get(qw(VDB_DIR),"/var/db/pkg") unless defined;
	}
	for($self->{overdir}) {
		$_= cfg()->get(qw(PORTDIR_OVERLAY),"") unless defined;
	};
	for ( @{$self}{qw(portdir vdb_dir overdir)} ) {
		next unless defined;
		$_ = getcwd()."/".$_ unless m{^/};
		$_.="/";
		s{/[./]*/}{/}g;
	};
	my $pats = $data{pats};
	if ( !defined($pats) ) {
		$pats = $data{pats} = [ ];
	} elsif ( ref $pats eq 'ARRAY' ) {
		# all is well
	} elsif ( ref $pats ) {
		die "got a ", ref $pats, " as pats\n";
	} else {
		$pats = $data{pats} = [ $pats ];
	}
	for ( @$pats ) {
		$_ = qr($_);
	}
	confess "\$pats should be an array ref!" unless ref $pats eq 'ARRAY';

	$self->{versions}=1 if $self->builds() || $self->latest();
	unless ( $self->{installed} || $self->{uninstalled} ) {
		$self->{installed} = $self->{uninstalled} = 1
	};
	return $self;
};
sub ls_uver($$) {
	my $self = shift;
	my $cat = shift;
	my $pkg = shift;
	my $pre = $self->{portdir}."/".$cat."/".$pkg."/$pkg-";
	my $len = length($pre);
	@_ = glob("${pre}*.ebuild");
	@_ = map { substr($_,$len) } @_;
	@_ = map { substr($_,0,-7) } @_;
	@_;
};
sub ls_iver($$) {
	my $self = shift;
	my $cat = shift;
	my $pkg = shift;
	my $pre = $self->{vdb_dir}."/".$cat."/".$pkg."-";
	my $len = length($pre);
	@_ = glob("${pre}[0-9]*");
	@_ = map { substr($_,$len) } @_;
	@_;
};
sub ls_pkgs($$){
	return map {
		if ( /^canna-2ch/ ) {
			s/-2ch-[0-9].*/-2ch/;
		} elsif ( /^font-adobe-\d+dpi/ ) {
			s/dpi-[0-9].*/dpi/;
		} else {
			s/-[0-9].*//;
		};
		$_;
	} ls_dirs( $_[0],$_[1] );
};
sub ls_dirs($$){
	my ( $dir, $allowfail ) = (shift,shift);
	if ( opendir(my $DIR, $dir) ) {
		my @x= readdir($DIR);
		@x=grep {
			$_ ne '.' && $_ ne 'CVS' && $_ ne '..' && -d $dir."/".$_
		} @x;
		return @x;
	};
	return () if $allowfail;
	confess "opendir:$dir:$!\n";
};
sub accept($$$@) {
	my ( $self, $cat, $pkg, @vers ) = @_;

	splice(@vers,0,-1) if ( $self->latest() );
	if ( $self->builds() ) {
		$cat = join("/", $self->portdir(),$cat);
		for ( @vers ) {
			$self->output(join("/",$cat,$pkg,$pkg."-".$_ .".ebuild"));
		};
	} elsif ( $self->versions() ) {
		for (@vers ) {
			$self->output($cat."/".$pkg."-".$_);
		};
	} else {
		$self->output($cat."/".$pkg);
	};
};
sub not_installed($$$){
	my ( $self, $cat, $pkg ) = @_;
	my $globspec = $self->vdb_dir()."/$cat/$pkg-[0-9]*/.";
	return !glob($globspec);
};
sub check_pats($@){
	my $self = shift;
	local $_ = shift;
	return 1 unless @_;
	for my $re ( @_ ) {
		#	confess "internal error" if ref $re ne 'Regexp';
		return 1 if /$re/;
	};
	return 0;
};
sub run($) {
	my $self=shift;
	my $idir = $self->vdb_dir();
	my $udir = $self->portdir();
	my @pats = @{$self->{pats}};

	my %cat;
	$cat{$_} = undef for(grep { /-/ } ls_dirs($udir,0));
	$cat{$_} = undef for(grep { /-/ } ls_dirs($idir,0));
	my $x=0;
	for my $cat ( sort keys %cat ) {
		my %pkg;
		$pkg{$_} |= 1 for(ls_pkgs("$udir/$cat",1));
		$pkg{$_} |= 2 for(ls_pkgs("$idir/$cat",1));

		if(!$self->installed()){
			for(keys %pkg) {
				delete $pkg{$_} if $pkg{$_} & 2;
			};
		};
		if(!$self->uninstalled()){
			for(keys %pkg) {
				delete $pkg{$_} unless $pkg{$_} & 2;
			};
		};

		for my $pkg ( sort keys %pkg ) {
			my $qua = $cat."/".$pkg;
			next unless $self->check_pats( $qua , @pats );
			if ( $self->versions() ) {
				my %ver;
				$ver{$_} |= 1 for $self->ls_uver($cat,$pkg);
				$ver{$_} |= 2 for $self->ls_iver($cat,$pkg);
#    				if(!$self->installed()){
#    					for(keys %ver) {
#    						delete $ver{$_} if $ver{$_} & 2;
#    					};
#    				};
				if(!$self->uninstalled()){
					for(keys %ver) {
						delete $ver{$_} unless $ver{$_} & 2;
					};
				};
				$self->accept($cat,$pkg,sort keys %ver);
			} else {
				$self->accept($cat,$pkg);
			}
		};
	}
};
sub gen_methods($) {
	my ($self) = @_;
	die 'ref \$self="',ref $self,'"' unless $self->isa("Gentoo::Probe");
	no strict 'refs';
	for my $key (keys %{$self}){
		*$key = sub{
			my $self = shift;
			my $slot = \$self->{$key};
			my $res = $$slot;
			$$slot = shift if @_;
			$res;
		} unless defined &$key;
	};
};
1;