File Coverage

blib/lib/Exodist/Util/Sub.pm

Criterion	Covered	Total	%
statement	48	54	88.8
branch	6	8	75.0
condition	5	9	55.5
subroutine	12	15	80.0
pod	5	8	62.5
total	76	94	80.8

package Exodist::Util::Sub;
use strict;
use warnings;

use Exporter::Declare::Magic;
use Exodist::Util::Package qw/inject_sub/;
use Carp qw/croak/;
use B;
use Hash::FieldHash qw(fieldhash);

default_exports qw/
    enhance_sub
    /;

fieldhash my %STASH;

default_export( 'enhanced_sub', 'sublike' );
default_export( 'esub', 'sublike', \&enhanced_sub );

sub bless_code {
    my $class = shift;
    my %proto = @_;

    my $code = delete $proto{sub} || croak "No code provided";
    bless( $code, $class );
    $STASH{$code} = \%proto;

    return;
}

sub enhanced_sub {
    my ( $name, $code ) = @_;
    my ( $caller, $file, $line ) = caller;

    inject_sub( $caller, $name, $code )
        if $name;

    __PACKAGE__->bless_code(
        sub      => $code,
        end_line => $line,
    );

    return $code;
}

sub enhance_sub {
    my ($in) = @_;
    my $ref;
    if ( ref $in and ref $in eq 'CODE' ) {
        $ref = $in;
    }
    else {
        $in =~ m/(.*::)?([^:]+)$/;
        my ( $caller, $sub ) = ( $1, $2 );
        $caller =~ s/::$// if $caller;
        $caller ||= caller;
        $ref = \&{"$caller\::$sub"};
    }

    __PACKAGE__->bless_code( sub => $ref );

    return;
}

sub start_line {
    my $self = shift;
    return B::svref_2object($self)->START->line;
}

sub end_line {
    my $self = shift;
    return $STASH{$self}->{end_line};
}

sub original_name {
    my $self = shift;
    return B::svref_2object($self)->GV->NAME;
}

sub is_anon {
    my $self = shift;
    return $self->original_name eq '__ANON__' ? 1 : 0;
}

sub original_package {
    my $self = shift;
    return B::svref_2object($self)->GV->STASH->NAME;
}

1;

=head1 NAME

Exodist::Util::Sub - Subroutines with advanced information attached.

=head1 DESCRIPTION

This package allows you to enhance subs such that they can be directly queried
for information. You can also directly create enhanced subs.

=head1 SYNOPSYS

    package MyPackage;
    use strict;
    use warnings;
    use Exodist::Util::Sub;

    esub print_hi {
        print "hi\n";
    }

    enhanced_sub print_bye {
        print "bye\n";
    }

    sub print_ps {
        print "ps\n";
    }
    enhance_sub 'print_ps';

    sub print_pps {
        print "pps\n"
    }
    enhance_sub \&print_pps;

    sub print_ppps {
        print "ppps\n"
    }
    enhance_sub 'MyPackage::print_ppps';

    my $code = esub {
        print "code\n"
    }

    $code->(); # prints 'code'
    print $code->start_line(); # prints the approximate line on which the sub
                               # definition started.
    print $code->end_line();   # Same but the lane where the definition ended

    (\&print_hi)->start_line();
    (\&print_hi)->original_name;
    (\&print_hi)->original_package;
    (\&print_hi)->is_anon;

=head1 CREATING ENHANCED SUBS

    esub print_hi {
        print "hi\n";
    }

    enhanced_sub print_bye {
        print "bye\n";
    }

=head1 ENHANCING EXISTING SUBS

    sub print_ps {
        print "ps\n";
    }
    enhance_sub 'print_ps';

=head1 METHODS ATTACHED TO ENHANCED SUBS

=over 4

=item (\&sub)->start_line()

Get the starting line on which the sub was defined (from L)

=item (\&sub)->end_line()

Get the last line on which the sub was defined. (Only available for subs
created as enhanced.)

=item (\&sub)->original_name()

Returns the original name given to the sub. (Only available on subs enhanced
after the fact.)

=item (\&sub)->is_anon()

Returns true if the sub was declared as an anonymous sub.

=item (\&sub)->original_package()

Returns the name of the package in which the sub was defined.

=back

=head1 AUTHORS

Chad Granum L

=head1 COPYRIGHT

Copyright (C) 2010 Chad Granum

Exodist-Util is free software; Standard perl licence.

Exodist-Util is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE.  See the license for more details.