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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
use strictures 2;
use Test::More;
use Test::Fatal;
use Package::Variant ();
my @DECLARED;
BEGIN {
package TestSugar;
use Exporter 'import';
our @EXPORT_OK = qw( declare );
sub declare { push @DECLARED, [@_] }
$INC{'TestSugar.pm'} = __FILE__;
}
BEGIN {
package TestVariable;
use Package::Variant
importing => { 'TestSugar' => [qw( declare )] },
subs => [qw( declare )];
sub make_variant {
my ($class, $target, @args) = @_;
::ok(__PACKAGE__->can('install'), 'install() is available')
or ::BAIL_OUT('install() subroutine was not exported!');
::ok(__PACKAGE__->can('declare'), 'declare() import is available')
or ::BAIL_OUT('proxy declare() subroutine was not exported!');
declare target => $target;
declare args => [@args];
declare class => $class->_test_class_method;
install target => sub { $target };
install args => sub { [@args] };
}
sub _test_class_method {
return shift;
}
$INC{'TestVariable.pm'} = __FILE__;
}
my $variant = do {
package TestScopeA;
use TestVariable;
TestVariable(3..7);
};
ok defined($variant), 'new variant is a defined value';
ok length($variant), 'new variant has length';
is $variant->target, $variant, 'target was new variant';
is_deeply $variant->args, [3..7], 'correct arguments received';
is_deeply shift(@DECLARED), [target => $variant],
'target passed via proxy';
is_deeply shift(@DECLARED), [args => [3..7]],
'arguments passed via proxy';
is_deeply shift(@DECLARED), [class => 'TestVariable'],
'class method resolution';
is scalar(@DECLARED), 0, 'proxy sub called right amount of times';
use TestVariable as => 'RenamedVar';
is exception {
my $renamed = RenamedVar(9..12);
is_deeply $renamed->args, [9..12], 'imported generator can be renamed';
}, undef, 'no errors for renamed usage';
my @imported;
BEGIN {
package TestImportableA;
sub import { push @imported, shift }
$INC{'TestImportableA.pm'} = __FILE__;
package TestImportableB;
sub import { push @imported, shift }
$INC{'TestImportableB.pm'} = __FILE__;
package TestArrayImports;
use Package::Variant
importing => [
'TestImportableA',
'TestImportableB',
];
sub make_variant { }
$INC{'TestArrayImports.pm'} = __FILE__;
}
use TestArrayImports;
TestArrayImports(23);
is_deeply [@imported], [qw( TestImportableA TestImportableB )],
'multiple imports in the right order';
BEGIN {
package TestSingleImport;
use Package::Variant importing => 'TestImportableA';
sub make_variant { }
$INC{'TestSingleImport.pm'} = __FILE__;
}
@imported = ();
use TestSingleImport;
TestSingleImport(23);
is_deeply [@imported], [qw( TestImportableA )],
'scalar import works';
@imported = ();
TestSingleImport::->build_variant;
is_deeply [@imported], [qw( TestImportableA )],
'build_variant works';
like exception {
Package::Variant->import(
importing => \'foo', subs => [qw( foo )],
);
}, qr/importing.+option.+hash.+array/i, 'invalid "importing" option';
like exception {
Package::Variant->import(
importing => { foo => \'bar' }, subs => [qw( bar )],
);
}, qr/import.+argument.+foo.+not.+array/i, 'invalid import argument list';
like exception {
Package::Variant->import(
importing => [ foo => ['bar'], ['bam'], subs => [qw( bar )] ],
);
}, qr/value.+3.+importing.+not.+string/i, 'importing array invalid key';
like exception {
Package::Variant->import(
importing => [ foo => \'bam', subs => [qw( bar )] ],
);
}, qr/value.+2.+foo.+importing.+array/i, 'importing array invalid list';
BEGIN {
package TestOverrideName;
use Package::Variant;
sub make_variant_package_name {
my (undef, @args) = @_;
return $args[0];
}
sub make_variant {
install hey => sub { 'hey' };
}
}
is(TestOverrideName::->build_variant('hey'), 'hey');
is(hey->hey, 'hey', 'hey');
done_testing;
|
