carton-highlight-xs

#!/usr/bin/env perl
# Gist: <https://gist.github.com/zmughal/cfbbbd66ed0e6d4a5403951230520dce>

use strict;
use warnings;
use feature qw(say);

use Carton ();
use Path::Tiny;
use List::AllUtils qw(any first);
use ExtUtils::Installed;
use CPAN::Meta;
use Module::CPANfile;
use Module::CoreList;
use Capture::Tiny qw(capture_stdout);
use Term::ANSIColor qw(colored);
use Regexp::Assemble ();
use Config;
use Module::Util ();
use Module::XSOrPP qw(xs_or_pp);

# These dispatch to PP or XS implementations.
our %XS_OR_PP_DISPATCH = map $_ => 1, qw(
	B::Hooks::EndOfScope
	Package::Stash
	Class::Load
);

# Need to add to Module::XSOrPP's list.
push @Module::XSOrPP::XS_OR_PP_MODULES, qw(
	Sub::Identify
);

sub install_local_via_carton {
	unless( -r 'cpanfile' ) {
		my $meta_file = first { -f $_ } ('META.json', 'META.yml')
			or die "Missing cpanfile or META file to generate cpanfile";
		my $cpanfile = Module::CPANfile->from_prereqs({
			%{
				CPAN::Meta->load_file( $meta_file )->prereqs
			}{qw(configure build runtime)}
		});
		path('cpanfile')->spew_utf8( $cpanfile->to_string );
	}
	# Setting PERL_CPANM_OPT does not work with Carton because it is localized in Carton::Builder:
	#     $ grep PERL_CPANM_OPT $( pm_which Carton::Builder )
	# which means that this does not work:
	#     local $ENV{PERL_CPANM_OPT} = '--pureperl';
	# and neither do:
	# For ExtUtils::MakeMaker:
	#     local $ENV{PERL_MM_OPT} = 'PUREPERL_ONLY=1';
	# For Module::Build:
	#     local $ENV{PERL_MB_OPT} = '--pureperl-only';
	#
	# A quick patch is to comment out that line below that localizes PERL_CPANM_OPT:
	local $ENV{PERL_CPANM_OPT} = '--pureperl';
	# instead of
	#     system(qw(carton install))
	# we can patch as follows:
	system($^X,
		qw(-e), <<'EOF',
		use Module::Util qw(find_installed module_fs_path);
		use Path::Tiny;

		my $localize_line = 'local $ENV{PERL_CPANM_OPT};';
		my $module_to_patch = 'Carton::Builder';

		unshift @INC, sub {
			my ($coderef, $filename) = @_;
			return undef unless $filename eq module_fs_path($module_to_patch);

			my $content = path(find_installed('Carton::Builder'))->slurp_utf8;
			# comment out $localize_line
			$content =~ s/\Q@{[ $localize_line ]}\E/#$&/m;

			return \$content;
		};

		require Carton::CLI;
		Carton::CLI->new->run(@ARGV)
EOF
		qw(install)
	);
}

sub get_xs_packages {
	my $my_inc = [path('local')->absolute->canonpath];
	my $installed = ExtUtils::Installed->new( inc_override => $my_inc );
	my @packages;
	for my $module (grep(!/^Perl$/, $installed->modules())) {
		push @packages, $module if any { /\.$Config{dlext}$/ } $installed->files( $module )
	}

	\@packages;
}

sub classify_packages {
	my $my_inc = [path('local')->absolute->canonpath];
	my $installed = ExtUtils::Installed->new( inc_override => $my_inc );
	my %packages_to_class;
	for my $module (grep(!/^Perl$/, $installed->modules())) {
		my $xs_or_pp = xs_or_pp($module);
		my $is_core = Module::CoreList::is_core($module);
		$packages_to_class{$module} = $xs_or_pp;
		$packages_to_class{$module} = 'xs_or_pp_dispatch' if exists $XS_OR_PP_DISPATCH{$module};
		$packages_to_class{$module} = $xs_or_pp eq 'xs' ? 'xs_core' : 'core' if $is_core;
	}
	\%packages_to_class;
}

sub carton_tree_highlight_packages {
	my ($packages, $packages_to_class) = @_;

	my $data;

	my $ra = Regexp::Assemble->new;
	$ra->add(
		@$packages,
		grep { $packages_to_class->{$_} =~ /xs|core/ } keys %$packages_to_class
	);

	my %colormap = (
		'xs' => 'red',
		'xs_or_pp' => 'yellow',
		'xs_or_pp_dispatch' => 'cyan',
		'xs_core' => 'blue on_white',
		'core' => 'black on_white',
	);

	my ($tree) = capture_stdout {
		system(qw(carton tree));
	};

	my $ra_re = $ra->re;
	my $re = qr/ ^ (?<indent> \s* ) (?<package>$ra_re) (?= \s+ [(] )/xm;

	($data->{highlight} = $tree) =~ s/$re/$+{indent} . colored($+{package}, $colormap{$packages_to_class->{$+{package}}})/meg;

	my @used;
	push @used, $+{package} while $tree =~ /$re/g;
	$data->{matched} = \@used;

	$data;
}

sub main {
	install_local_via_carton;
	my $packages = get_xs_packages;
	my $packages_to_class = classify_packages;
	my $tree_data = carton_tree_highlight_packages( $packages, $packages_to_class );

	say $tree_data->{highlight};
	my @used = @{ $tree_data->{matched} };
	say "XS packages used (n=@{[ scalar @used ]}): [ @used ]";
}

main unless caller;