File Coverage

blib/lib/App/Midgen/Role/Experimental.pm

Criterion	Covered	Total	%
statement	24	106	22.6
branch	0	46	0.0
condition	0	7	0.0
subroutine	8	13	61.5
pod	3	3	100.0
total	35	175	20.0

package App::Midgen::Role::Experimental;

our $VERSION = '0.33_05';
$VERSION = eval $VERSION;    ## no critic

use constant {THREE => 3,};

use Types::Standard qw( Bool );
use Moo::Role;
#requires qw( debug );

use Try::Tiny;
use Data::Printer {caller_info => 1,};
use Term::ANSIColor qw( :constants colored colorstrip );
use List::MoreUtils qw(firstidx);


#######
# composed method degree of separation
# parent A::B - child A::B::C
#######
sub degree_separation {
	my $self   = shift;
	my $parent = shift;
	my $child  = shift;

	# Use of implicit split to @_ is deprecated
	my $parent_score = @{[split /::/, $parent]};
	my $child_score  = @{[split /::/, $child]};
	warn 'parent - ' . $parent . ' score - ' . $parent_score if $self->debug;
	warn 'child - ' . $child . ' score - ' . $child_score    if $self->debug;

	# switch around for a positive number
	return $child_score - $parent_score;
}


#######
# remove_noisy_children
#######
sub remove_noisy_children {
	my $self = shift;
	my $required_ref = shift || return;
	my @sorted_modules;

	foreach my $module_name (sort keys %{$required_ref}) {
		push @sorted_modules, $module_name;
	}

	p @sorted_modules if $self->debug;

	foreach my $parent_name (@sorted_modules) {
		my $outer_index = firstidx { $_ eq $parent_name } @sorted_modules;

		# inc so we don't end up with parent eq child
		$outer_index++;
		foreach my $inner_index ($outer_index .. $#sorted_modules) {
			my $child_name = $sorted_modules[$inner_index];

			# we just caught an undef
			next if not defined $child_name;
			if ($child_name =~ /^ $parent_name ::/x) {

				my $valied_seperation = 1;

				# as we only do this against -x, why not be extra vigilant
				$valied_seperation = THREE
					if $parent_name =~ /^Dist::Zilla|Moose|MooseX|Moo|Mouse/;

				# Checking for one degree of separation
				# ie A::B -> A::B::C is ok but A::B::C::D is not
				if ($self->degree_separation($parent_name, $child_name)
					<= $valied_seperation)
				{

					# Test for same version number
					if (colorstrip($required_ref->{$parent_name}) eq
						colorstrip($required_ref->{$child_name}))
					{
						if (not $self->quiet) {
							if ($self->verbose) {
								print BRIGHT_BLACK;
								print 'delete miscreant noisy child '
									. $child_name . ' => '
									. $required_ref->{$child_name};
								print CLEAR. "\n";
							}
						}
						try {
							delete $required_ref->{$child_name};
							splice @sorted_modules, $inner_index, 1;

							unless ($self->{modules}{$parent_name}) {
								$self->{modules}{$parent_name}{prereqs} = 'expermental';
								$self->{modules}{$parent_name}{version}
									= $required_ref->{$parent_name};
								$self->{modules}{$parent_name}{count} += 1;
							}
						};
						p @sorted_modules if $self->debug;

						# we need to redo as we just deleted a child
						redo;

					}
					else {

						# not my child so lets try the next one
						next;
					}
				}
			}
			else {

				# no more like the parent so lets start again
				last;
			}
		}
	}
	return;
}


#######
# remove_twins
#######
sub remove_twins {
	my $self = shift;
	my $required_ref = shift || return;
	my @sorted_modules;
	foreach my $module_name (sort keys %{$required_ref}) {
		push @sorted_modules, $module_name;
	}

	p @sorted_modules if $self->debug;

	# exit if only 1 Module found
	return if $#sorted_modules == 0;

	my $n = 0;
	while ($sorted_modules[$n]) {

		my $dum_name    = $sorted_modules[$n];
		my $dum_parient = $dum_name;
		$dum_parient =~ s/(::\w+)$//;

		my $dee_parient;
		my $dee_name;
		if (($n + 1) <= $#sorted_modules) {
			$n++;
			$dee_name    = $sorted_modules[$n];
			$dee_parient = $dee_name;
			$dee_parient =~ s/(::\w+)$//;
		}

		# Checking for same patient and score
		if ( $dum_parient eq $dee_parient
			&& $self->degree_separation($dum_name, $dee_name) == 0)
		{

			# Test for same version number
			if ($required_ref->{$sorted_modules[$n - 1]} eq
				$required_ref->{$sorted_modules[$n]})
			{
				if (not $self->quiet) {
					if ($self->verbose) {
						print BRIGHT_BLACK;

						# stdout - 'i have found twins';
						print $dum_name . ' => '
							. $required_ref->{$sorted_modules[$n - 1]};
						print BRIGHT_BLACK ' <-twins-> '
							. $dee_name . ' => '
							. $required_ref->{$sorted_modules[$n]};
						print CLEAR "\n";
					}
				}

				#Check for valid parent
				my $version;

				$version = $self->get_module_version($dum_parient);

				if (version::is_lax($version)) {

					#Check parent version against a twins version
					if ($version eq $required_ref->{$sorted_modules[$n]}) {
						print $dum_parient . ' -> '
							. $version
							. " is the parent of these twins\n"
							if $self->verbose;
						$required_ref->{$dum_parient} = $version;
						$self->_set_found_twins(1);
					}
				}
			}
		}
		$n++ if ($n == $#sorted_modules);
	}
	return;
}

no Moo::Role;

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

App::Midgen::Roles::Experimental - used by L<App::Midgen>

=head1 VERSION

version: 0.33_05

=head1 METHODS

=over 4

=item * degree_separation

now a separate Method, returns an integer.

=item * remove_noisy_children

Parent A::B has noisy Children A::B::C and A::B::D all with same version number.

=item * remove_twins

Twins E::F::G and E::F::H  have a parent E::F with same version number,
 so we add a parent E::F and re-test for noisy children,
 catching triplets along the way.

=item * run

=back

=head1 AUTHOR

See L<App::Midgen>

=head2 CONTRIBUTORS

See L<App::Midgen>

=head1 COPYRIGHT

See L<App::Midgen>

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut