1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
#!/usr/bin/perl
use v5.14;
use warnings;
use Test2::V0;
use meta;
no warnings qw( meta::experimental );
sub testfunc ($$@) { }
{
my $metasub = meta::package->get( "main" )->get_symbol( '&testfunc' );
isa_ok( $metasub, [ "meta::subroutine" ], '$metasub isa meta subroutine' );
ok( $metasub->is_subroutine, '$metasub->is_subroutine' );
# This method should always exist even on perls before feature 'class', and
# return false on plain sub.
ok( !$metasub->is_method, '$metasub->is_method is false' );
is( $metasub->subname, "main::testfunc",
'$metasub->subname' );
is( $metasub->prototype, '$$@',
'$metasub->prototype' );
$metasub = meta::for_reference( \&testfunc );
ok( $metasub->is_subroutine, '$metasub for reference ->is_subroutine' );
ref_is( $metasub->reference, \&testfunc,
'meta::for_reference ARRAY yields metasub' );
}
sub to_be_modified { }
{
my $metasub = meta::package->get( "main" )->get_symbol( '&to_be_modified' );
$metasub->set_subname( "a-new-name-here" ); # does not have to be valid
is( $metasub->subname, "main::a-new-name-here",
'$metasub->subname after ->set_subname' );
$metasub->set_subname( "different::package::name" );
is( $metasub->subname, "different::package::name",
'$metasub->subname after ->set_subname on different package' );
$metasub->set_prototype( '$$' );
is( $metasub->prototype, '$$',
'$metasub->prototype after ->set_prototype' );
}
{
my $metapkg = meta::package->get( "main" );
my $metasub = $metapkg->add_named_sub(
newly_added_sub => sub { "the result" }
);
ok( $metasub->is_subroutine, '->add_named_sub returned a metasub' );
is( main->newly_added_sub(), "the result",
'Result of calling sub added by ->add_named_sub' );
is( $metapkg->get_symbol( '&newly_added_sub' )->subname, "main::newly_added_sub",
'Newly added sub has correct subname' );
}
# ->get_symbol and friends should not get confused by subclass method resolution
{
package Class1 { sub a_method {} }
package Class2 { use base 'Class1'; }
my $metapkg1 = meta::package->get( "Class1" );
ok( $metapkg1->try_get_symbol( '&a_method' ),
'metapkg for Class1 sees a_method' );
# Force the method cache to exist
Class2->a_method();
my $metapkg2 = meta::package->get( "Class2" );
ok( !$metapkg2->try_get_symbol( '&a_method' ),
'metapkg for Class2 does not see a_method' );
$metapkg2->add_symbol( '&a_method' => sub {} );
ok( $metapkg2->try_get_symbol( '&a_method' ),
'metapkg for Class2 now sees overridden a_method' );
}
done_testing;
|
