Skip to content

Instantly share code, notes, and snippets.

@zmughal
Last active May 24, 2023 21:14
Show Gist options
  • Save zmughal/cfbbbd66ed0e6d4a5403951230520dce to your computer and use it in GitHub Desktop.
Save zmughal/cfbbbd66ed0e6d4a5403951230520dce to your computer and use it in GitHub Desktop.
#!/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;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment