Skip to content

Commit

Permalink
Add code for coderef info lookup
Browse files Browse the repository at this point in the history
  • Loading branch information
@exodist
exodist committed Mar 20, 2013
1 parent 4519fb2 commit 50d2a3d
Show file tree
Hide file tree
Showing 3 changed files with 72 additions and 2 deletions.
24 changes: 23 additions & 1 deletion lib/perl5i/2/CODE.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,10 +4,12 @@ use 5.010;
use strict;
use warnings;

require B;

This comment has been minimized.

Sign in to view

Copy link
@schwern

schwern Mar 22, 2013

Contributor

Load this on demand inside the methods as needed. Otherwise it adds 5-10% to our load time.

# Can't use sigantures here, Signatures needs CODE.

use Hash::FieldHash qw(fieldhashes);
fieldhashes \my(%Signatures);
fieldhashes \my ( %Signatures, %Endline );

sub __set_signature {
$Signatures{$_[0]} = $_[1];
Expand All @@ -17,4 +19,24 @@ sub signature {
return $Signatures{$_[0]};
}

sub start_line {
return B::svref_2object( $_[0] )->START->line;
}

sub __set_end_line {
return $Endline{$_[0]} = $_[1];
}

sub end_line {
return $Endline{$_[0]};
}

sub original_name {
return B::svref_2object( $_[0] )->GV->NAME;
}

sub original_package {
return B::svref_2object( $_[0] )->GV->STASH->NAME;
}

This comment has been minimized.

Sign in to view

Copy link
@schwern

schwern Mar 22, 2013

Contributor

"original" is a bit ambiguous. Its really what they were "declared" as.

1;
5 changes: 4 additions & 1 deletion lib/perl5i/2/Signatures.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -105,7 +105,10 @@ sub set_signature {
is_method => $args{is_method},
);

perl5i::2::CODE::__set_signature($args{code}, $sig);
perl5i::2::CODE::__set_signature( $args{code}, $sig );

perl5i::2::CODE::__set_end_line( $args{code}, $args{end_line} )
if $args{end_line};

return $sig;
}
Expand Down
45 changes: 45 additions & 0 deletions t/codref.t
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,45 @@
#!/usr/bin/perl
use strict;
use warnings;

use perl5i::latest;
use Test::More;

# Note, do not let the line number for these subs change!

This comment has been minimized.

Sign in to view

Copy link
@schwern

schwern Mar 22, 2013

Contributor

You can affix the line numbers with # line 9. Then no matter what the line number really is, Perl will count from 9 after that. Good trick for testing.

This comment has been minimized.

Sign in to view

Copy link
@exodist

exodist Mar 22, 2013

Author Contributor

Yes, but then EVERY line is offset, unless I wrap it in a string eval. That makes debugging broken tests hard.

This comment has been minimized.

Sign in to view

Copy link
@schwern

schwern Mar 23, 2013

Contributor

Just thought of something... use __LINE__ to record the line numbers and reference them in the test.

my %lines;

$lines{a_method}{start} = __LINE__ + 1;
method a_method {
    ...
}
$lines{a_method}{end} = __LINE__ - 1;

...

my $code = __PACKAGE__->can("a_method");
is( $code->start_line, $lines{a_method}{start} );
sub foo { 1 }
my $foo2 = sub { 1 };
method a_method {
print "1";
print "2";
}
func a_func {
print "1";
print "2";
}

my $code = __PACKAGE__->can('foo');

is( $code->original_name, 'foo', "Can get original name" );
is( $code->original_package, 'main', "Can get original package" );
is( $code->start_line, 9, "Can get start line" );
is( $code->end_line, undef, "No end line set" );

This comment has been minimized.

Sign in to view

Copy link
@schwern

schwern Mar 22, 2013

Contributor

The behavior of end_line for subroutines not declared using our own signature methods concerns me. I'm afraid its an error trap.

I would say lacking an end line should be an exception. One needs to write error handling code for that case anyway, might as well make it a real error so if you forget to write the error handling code you know.

$code = $foo2;
is( $code->original_name, '__ANON__', "Can get original name (has none)" );
is( $code->original_package, 'main', "Can get original package" );
is( $code->start_line, 10, "Can get start line" );
is( $code->end_line, undef, "No end line set" );

$code = __PACKAGE__->can('a_method');
is( $code->original_name, 'a_method', "Can get original name" );
is( $code->original_package, 'main', "Can get original package" );
is( $code->start_line, 11, "Can get start line" );
is( $code->end_line, 14, "Can get end line" );

$code = __PACKAGE__->can('a_func');
is( $code->original_name, 'a_func', "Can get original name" );
is( $code->original_package, 'main', "Can get original package" );
is( $code->start_line, 16, "Can get start line (or first statement line)" );
is( $code->end_line, 18, "Can get end line" );

done_testing;

0 comments on commit 50d2a3d

Please sign in to comment.