File Coverage

lib/Submodules.pm

Criterion	Covered	Total	%
statement	93	95	97.8
branch	17	26	65.3
condition	7	12	58.3
subroutine	16	16	100.0
pod	1	4	25.0
total	134	153	87.5

package Submodules;
use strict;
use warnings;
use Submodules::Result ();
use File::Spec;
use File::Find qw();
use Carp;
use File::Basename;
our $VERSION = '1.0015';

my $names;

sub import {
	my $self = shift;
	my $pack = caller;
	my $name = shift;
	if (defined($name) and length $name) {
		no strict 'refs';
		croak "Cannot export symbol '&${pack}::$name' because it's already defined" if defined &{"${pack}::$name"};
		*{"${pack}::$name"} = \&submodules;
		$names->{$pack} = $name;
	}
}

sub submodules (;*) {
	my @caller = caller(0);
	my $name = 'submodules';
	if (exists $names->{$caller[0]}) {
		$name = $names->{$caller[0]} if length $names->{$caller[0]};
	}
	my $usage = "Usage:\n   $name name::space\n";
	croak $usage if @_ > 1;
	if (not defined wantarray) {
		carp "Useless call of '$name' in void context";
		return;
	}
	my $query = shift;
	$query = $caller[0] unless defined $query;
	my $self = {
		list		=> [],
		caller_abs	=> File::Spec->rel2abs($caller[1]),
		query		=> $query,
		seen_paths	=> {},
	};
	bless $self, __PACKAGE__;
	my @members = split /(?:::|')/, $query;
	my @inc;
	for my $i (@INC) {
		my $abs = File::Spec->rel2abs($i);
		unless (exists $self->{seen_paths}->{$abs}) {
			push @inc, $abs;
			$self->{seen_paths}->{$abs} = 1;
		}
	}
	for my $i (@inc) {
		my $inc_dir = File::Spec->rel2abs($i);
		if (-f (my $file = File::Spec->catfile($inc_dir, @members).'.pm')) {
			$file = _get_abs_path($file);
			my $caller = _get_abs_path($caller[1]);
			$self->process_file($inc_dir, $file) unless $file eq $caller;
		}
		return $self->{list}->[0] if @{$self->{list}} and not wantarray;
		if (-d (my $path = File::Spec->catfile($inc_dir, @members))) {
			$self->process_path($inc_dir, $path);
		}
	}
	@{$self->{list}};
};

sub find {
	my $self = shift;
	goto &submodules;
}

sub process_path {
	my $self = shift;
	my $path_abs = shift;
	my $path = shift;
	File::Find::find (
		{
			no_chdir	=> 1,
			preprocess	=> sub { # Introduced after seeing the directory contents order behave unexpectedly on some file systems
				my @items = sort {$a cmp $b} @_;
			},
			wanted		=> sub {
				$self->process_file($path_abs, $File::Find::name)
			},
		},
		$path,
	);
}

sub process_file {
	my $self = shift;
	my $path_abs = shift;
	my $file = shift;
	return unless $file =~ /(\.pm)$/i and -f $file and my $extension = $1;
	my $file_abs = File::Spec->rel2abs($file);
	my $file_rel = File::Spec->abs2rel($file_abs);
	my $filename = basename $file_abs;
	my @parts_path = File::Spec->splitdir($path_abs);
	my @parts = File::Spec->splitdir($file_abs);
	splice @parts, 0, scalar @parts_path;
	$parts[$#parts] = substr $parts[$#parts], 0, - length $extension;
	my $code_path = join '::', @parts;
	my $perl_path = join('/', @parts).$extension;
	my $name = $parts[$#parts];
	push @{$self->{list}}, Submodules::Result->new (
		Name		=> $name,
		AbsPath		=> $file_abs,
		RelPath		=> $file_rel,
		Path		=> $perl_path,
		Clobber		=> $self->{seen_paths}->{$name},
		Module		=> $code_path,
	);
	$self->{seen_paths}->{$name} = $file_abs;
}

sub _get_abs_path {
	my $path = shift;
	my @parts = File::Spec->splitdir($path);
	my $file = File::Spec->catfile(@parts);
	File::Spec->rel2abs($file);
}

1;

__END__