view release on metacpan or  search on metacpan

lib/Devel/Examine/Subs.pm  view on Meta::CPAN

}

#
# publicly available semi-private developer methods
#

sub add_functionality {

    trace() if $ENV{TRACE};

    my $self = shift;
    my $p = $self->_params(@_);

    $self->_config($p);

    my $to_add = $self->{params}{add_functionality};
    my $in_prod = $self->{params}{add_functionality_prod};

    my @allowed = qw(
        pre_proc
        post_proc
        engine
    );

    my $is_allowed = 0;

    for (@allowed){
        if ($_ eq $to_add){
            $is_allowed = 1;
            last;
        }
    }

    if (! $is_allowed){
        confess "Adding a non-allowed piece of functionality...\n";
    }

    my %dt = (
            pre_proc => sub {
                trace() if $ENV{TRACE};
                return $in_prod
                    ? $INC{'Devel/Examine/Subs/Preprocessor.pm'}
                    : 'lib/Devel/Examine/Subs/Preprocessor.pm';
            },

            post_proc => sub {
                trace() if $ENV{TRACE};
                return $in_prod
                    ? $INC{'Devel/Examine/Subs/Postprocessor.pm'}
                    : 'lib/Devel/Examine/Subs/Postprocessor.pm';
            },

            engine => sub {
                trace() if $ENV{TRACE};
                return $in_prod
                    ? $INC{'Devel/Examine/Subs/Engine.pm'}
                    : 'lib/Devel/Examine/Subs/Engine.pm';
            },
    );

    my $caller = (caller)[1];

    open my $fh, '<', $caller
      or confess "can't open the caller file $caller: $!";

    my $code_found = 0;
    my @code;

    while (<$fh>){
        chomp;
        if (m|^#(.*)<des>|){
            $code_found = 1;
            next;
        }
        next if ! $code_found;
        last if m|^#(.*)</des>|;
        push @code, $_;
    }

    my $file = $dt{$to_add}->();
    my $copy = $self->{params}{copy};

    if ($copy) {
        copy $file, $copy or die $!;
        $file = $copy;
    }

    my $sub_name;

    if ($code[0] =~ /sub\s+(\w+)/){
        $sub_name = $1;
    }
    else {
        confess "couldn't extract the sub name";
    }

    my $des = Devel::Examine::Subs->new(file => $file);

    my $existing_subs = $des->all;

    if (grep { $sub_name eq $_ } @$existing_subs) {
        confess "the sub you're trying to add already exists";
    }

    $des = Devel::Examine::Subs->new(
        file => $file,
        engine => 'objects',
        post_proc => [qw(subs end_of_last_sub)],
    );

    $p = {
        engine => 'objects',
        post_proc => [qw(subs end_of_last_sub)],
        post_proc_return => 1,
    };

    my $start_writing = $des->run($p);

    my $rw = File::Edit::Portable->new;

    $rw->splice(file => $file, insert => \@code, line => $start_writing);