Skip to content

Instantly share code, notes, and snippets.

@dolmen

dolmen/cpanm-dynamic-patch.pl

Forked from kentfredric/winrar.pl
Last active August 29, 2015 14:14
Show Gist options
  • Save dolmen/3b2a03fdffd113fbf73b to your computer and use it in GitHub Desktop.
Save dolmen/3b2a03fdffd113fbf73b to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. dolmen revised this gist Jan 26, 2015. 1 changed file with 1 addition and 0 deletions.
    1 change: 1 addition & 0 deletions cpanm-dynamic-patch.pl
    View file
    Original file line number Diff line number Diff line change
    @@ -33,6 +33,7 @@


    # Patch App::cpanminus::script::install_module
    # From this point this is kentfredric's original code

    require App::cpanminus::script;
    {
  2. dolmen revised this gist Jan 26, 2015. 2 changed files with 63 additions and 100 deletions.
    63 changes: 63 additions & 0 deletions cpanm-dynamic-patch.pl
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,63 @@
    #!/usr/bin/env perl
    # Dynamically patch cpanm
    # Alternative implementation to:
    # https://gist.github.com/kentfredric/ce1df3e7e509e071b63d

    use strict;
    use 5.010001;
    use warnings;

    use Scalar::Util qw(blessed);
    use File::Which qw(which);

    {
    # Make 'use App::cpanminus::scipt;' do nothing
    local $INC{'App/cpanminus/script.pm'} = 1;
    require(which 'cpanm');
    }

    # Find the fatpacked container object
    my $fatpacked;
    for my $inc (@INC) {
    if (blessed($inc) && index(ref($inc), 'FatPacked::') == 0) {
    $fatpacked = $inc;
    last;
    }
    }

    die "Couldn't hack into fatpacked script!" unless $fatpacked;

    # Delete external modules embedded in the script, and let us load them
    # from the usual place
    delete @{$fatpacked}{ grep !m<\AApp/cpanminus>, keys %$fatpacked };


    # Patch App::cpanminus::script::install_module

    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;
    }
    100 changes: 0 additions & 100 deletions winrar.pl
    View file
    Original file line number Diff line number Diff line change
    @@ -1,100 +0,0 @@
    #!/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;
    }
  3. @kentfredric kentfredric created this gist Jan 23, 2015.
    100 changes: 100 additions & 0 deletions winrar.pl
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,100 @@
    #!/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;
    }