-
-
Save dolmen/3b2a03fdffd113fbf73b to your computer and use it in GitHub Desktop.
Monkey patching a fatpacked script (cpanm)
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #!/usr/bin/env perl | |
| # FILENAME: unfatten.pl | |
| # CREATED: 01/24/15 04:55:06 by Kent Fredric (kentnl) <[email protected]> | |
| # ABSTRACT: Attempt to extract files from a codes fatpacked library. | |
| use strict; | |
| use 5.010001; | |
| use warnings; | |
| { | |
| package Capture; | |
| use Tie::Array; | |
| our @ISA = ('Tie::Array'); | |
| sub TIEARRAY { | |
| my ( $classname, %args ) = @_; | |
| return bless { | |
| original => $args{original}, | |
| storage => $args{storage}, | |
| }, $classname; | |
| } | |
| sub FETCH { | |
| my ( $self, $index ) = @_; | |
| return $self->{original}->[$index]; | |
| } | |
| sub FETCHSIZE { | |
| my ($self) = @_; | |
| return scalar @{ $self->{original} }; | |
| } | |
| sub UNSHIFT { | |
| my ( $self, @list ) = @_; | |
| push @{ $self->{storage} }, $_ for @list; | |
| die "Capture done"; | |
| } | |
| } | |
| my $storage = []; | |
| sub capture { | |
| my $original = [@INC]; | |
| { | |
| local @INC; | |
| tie @INC, 'Capture', ( storage => $storage, original => $original ); | |
| local $@; | |
| eval { require "/home/kent/perl5/perlbrew/bin/cpanm"; }; | |
| } | |
| untie @INC; | |
| @INC = @{$original}; | |
| } | |
| use Scalar::Util qw(blessed); | |
| capture(); | |
| for my $elem ( @{$storage} ) { | |
| next unless ref $elem; | |
| next unless blessed $elem; | |
| my $class = blessed $elem; | |
| my $orig = $class->can('INC'); | |
| my $new = sub { | |
| return unless $_[1] =~ qr{\AApp/cpanminus}; | |
| print "Fetching $_[1]\n"; | |
| return $orig->(@_); | |
| }; | |
| { | |
| no strict 'refs'; | |
| no warnings 'redefine'; | |
| *{"${class}::INC"} = $new; | |
| } | |
| unshift @INC, $elem; | |
| } | |
| require App::cpanminus::script; | |
| { | |
| my $old = App::cpanminus::script->can('install_module'); | |
| my $stack = []; | |
| sub pp_stack { | |
| printf "\e[31m%s\e[0m", join qq[->\n], map { $_->[0] } @{$stack}; | |
| } | |
| my $new = sub { | |
| my ( $self, $module, $depth, $version ) = @_; | |
| push @{$stack}, [ $module, $depth, $version ]; | |
| pp_stack; | |
| my $exit = $self->$old( $module, $depth, $version ); | |
| pop @{$stack}; | |
| return $exit; | |
| }; | |
| { | |
| no strict 'refs'; | |
| no warnings 'redefine'; | |
| *{"App::cpanminus::script::install_module"} = $new; | |
| } | |
| } | |
| unless (caller) { | |
| my $app = App::cpanminus::script->new; | |
| $app->parse_options(@ARGV); | |
| exit $app->doit; | |
| } |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment