The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

ETHER / Class-Method-Modifiers-2.15 / t / 120-fresh.t 

            

              
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
91
92
93
94
95

              
use strict;
use warnings;
use Test::More 0.88;
use if $ENV{AUTHOR_TESTING}, 'Test::Warnings';
use B 'svref_2object';
BEGIN {
    package P1;
    sub new { bless {}, shift }
    sub m1 { 'P1/m1' }
    package P2;
    our @ISA = 'P1';
    use Class::Method::Modifiers 'fresh';
    sub m6 { 'P2/m6' }
    fresh m2 => sub { 'P2/m2' };
    fresh [qw(m3 m4)] => sub { 'P2/m3/m4' };
    my $closee = 'closee';
    fresh m5 => sub { "P2/m5/$closee" };
}
BEGIN {
    package P3;                 # like P2, but using install_modifier
    our @ISA = 'P1';
    sub m6 { 'P3/m6' }
    package main;
    use Class::Method::Modifiers 'install_modifier';
    install_modifier P3 => fresh =>     m2      => sub { 'P3/m2' };
    install_modifier P3 => fresh => [qw(m3 m4)] => sub { 'P3/m3/m4' };
    my $closee = 'closee';
    install_modifier P3 => fresh =>     m5      => sub { "P3/m5/$closee" };
}
can_ok(P2->new, @$_) for [
    qw(m2),                     # single-name call to fresh
    qw(m3 m4),                  # multi-name call
    qw(m5),                     # code ref is closure
];
is(P2->new->m5, 'P2/m5/closee', 'closure works');
can_ok(P3->new, qw(m2 m3 m4 m5));
is(P3->new->m5, 'P3/m5/closee', 'closure works with install_modifier');
for my $class (qw(P2 P3)) {
    my $method = $class->can('m5');
    is(svref_2object($method)->GV->STASH->NAME, $class,
       "method installed in $class has correct stash name");
}
{
    package P2;
    eval { fresh m1 => sub {} };
    ::like($@,
           qr/^Class P2 already has a method named 'm1'/,
           'fresh: exception when inherited method exists');
    eval { fresh m6 => sub {} };
    ::like($@,
           qr/^Class P2 already has a method named 'm6'/,
           'fresh: exception when local method exists');
    eval { fresh '=:=' => sub {} };
    ::like($@,
           qr/^Invalid method name '=:='/,
           'fresh: exception when name invalid');
}
eval { install_modifier P3 => fresh => m1 => sub {} };
like($@,
     qr/^Class P3 already has a method named 'm1'/,
     'install_modifier: exception when inherited method exists');
eval { install_modifier P3 => fresh => m6 => sub {} };
like($@,
     qr/^Class P3 already has a method named 'm6'/,
     'install_modifier: exception when local method exists');
eval { install_modifier P3 => fresh => '=:=' => sub {} };
like($@,
     qr/^Invalid method name '=:='/,
     'install_modifier: exception when name invalid');
done_testing;