Skip to content

Commit 3ad1630

Browse files
toddrtoddr
authored
Merge pull request #3 from toddr-bot/koan.toddr.bot/add-object-wrap-tests
test: add object wrapping tests + fix Build.PL URLs
2 parents 5f5de78 + 56fc702 commit 3ad1630

1 file changed

Lines changed: 225 additions & 0 deletions

File tree

‎t/02-wrap-objects.t‎

Lines changed: 225 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,225 @@
1+
use strict;
2+
use warnings;
3+
use Test::More;
4+
5+
use Safe;
6+
use Safe::Hole;
7+
8+
# Helper packages for testing object wrapping
9+
10+
{
11+
12+
package Animal;
13+
sub new {
14+
my ( $class, %args ) = @_;
15+
bless { name => $args{name} || 'unknown', sound => $args{sound} || '...' }, $class;
16+
}
17+
sub name { return $_[0]->{name} }
18+
sub sound { return $_[0]->{sound} }
19+
sub speak { return $_[0]->{name} . ' says ' . $_[0]->{sound} }
20+
21+
sub with_args {
22+
my ( $self, $prefix, $suffix ) = @_;
23+
return $prefix . $self->{name} . $suffix;
24+
}
25+
26+
sub returns_list {
27+
my ($self) = @_;
28+
return ( $self->{name}, $self->{sound} );
29+
}
30+
31+
sub dies_on_purpose {
32+
my ($self) = @_;
33+
die "intentional error from $self->{name}\n";
34+
}
35+
36+
sub DESTROY { } # explicit no-op to avoid AUTOLOAD dispatch
37+
}
38+
39+
{
40+
41+
package Dog;
42+
our @ISA = ('Animal');
43+
44+
sub new {
45+
my ( $class, %args ) = @_;
46+
$args{sound} = 'woof';
47+
my $self = $class->SUPER::new(%args);
48+
$self->{tricks} = $args{tricks} || [];
49+
return $self;
50+
}
51+
52+
sub tricks { return @{ $_[0]->{tricks} } }
53+
sub trick_count { return scalar @{ $_[0]->{tricks} } }
54+
sub fetch { return $_[0]->{name} . ' fetches the ball' }
55+
}
56+
57+
{
58+
59+
package Counter;
60+
sub new { bless { count => 0 }, shift }
61+
sub inc { $_[0]->{count}++; return $_[0]->{count} }
62+
sub value { return $_[0]->{count} }
63+
sub reset { $_[0]->{count} = 0; return 0 }
64+
}
65+
66+
###################################
67+
# Basic object wrapping
68+
###################################
69+
70+
my $safe = Safe->new;
71+
my $hole = Safe::Hole->new( {} );
72+
73+
my $cat = Animal->new( name => 'Cat', sound => 'meow' );
74+
75+
# Wrap object and share it with the compartment
76+
my $wrapped_cat = $hole->wrap( $cat, $safe, '$cat' );
77+
ok( $wrapped_cat, 'wrap() returns a wrapped object' );
78+
like( ref($wrapped_cat), qr/Safe::Hole/, 'Wrapped object class contains Safe::Hole' );
79+
80+
# Method calls through wrapper via reval
81+
is( $safe->reval('$cat->name()'), 'Cat', 'name() method through wrapped object' );
82+
is( $safe->reval('$cat->sound()'), 'meow', 'sound() method through wrapped object' );
83+
is( $safe->reval('$cat->speak()'), 'Cat says meow', 'speak() method combining fields' );
84+
is( $@, '', 'No errors from basic method calls' );
85+
86+
###################################
87+
# Method calls with arguments
88+
###################################
89+
90+
is( $safe->reval('$cat->with_args("[", "]")'), '[Cat]', 'Method with multiple arguments' );
91+
is( $@, '', 'No error from method with arguments' );
92+
93+
###################################
94+
# List context return values
95+
###################################
96+
97+
my @result = $safe->reval('$cat->returns_list()');
98+
is_deeply( \@result, [ 'Cat', 'meow' ], 'Method returning list in list context' );
99+
is( $@, '', 'No error from list-returning method' );
100+
101+
###################################
102+
# Error propagation through wrapped methods
103+
###################################
104+
105+
$safe->reval('$cat->dies_on_purpose()');
106+
like( $@, qr/intentional error from Cat/, 'die in wrapped method propagates to $@' );
107+
108+
###################################
109+
# Calling undefined methods on wrapped objects
110+
###################################
111+
112+
$safe->reval('$cat->nonexistent_method()');
113+
like( $@, qr/(?:nonexistent_method|Can't locate)/i, 'Undefined method on wrapped object sets $@' );
114+
115+
###################################
116+
# Inheritance through wrapping
117+
###################################
118+
119+
my $dog = Dog->new( name => 'Rex', tricks => [ 'sit', 'shake', 'roll' ] );
120+
my $wrapped_dog = $hole->wrap( $dog, $safe, '$dog' );
121+
ok( $wrapped_dog, 'wrap() returns wrapped subclass object' );
122+
123+
# Methods from subclass
124+
is( $safe->reval('$dog->fetch()'), 'Rex fetches the ball', 'Subclass method through wrapper' );
125+
is( $safe->reval('$dog->trick_count()'), 3, 'Subclass method returning count' );
126+
is( $@, '', 'No errors from subclass method calls' );
127+
128+
# Methods inherited from parent
129+
is( $safe->reval('$dog->name()'), 'Rex', 'Inherited method through wrapper' );
130+
is( $safe->reval('$dog->sound()'), 'woof', 'Inherited accessor through wrapper' );
131+
is( $safe->reval('$dog->speak()'), 'Rex says woof', 'Inherited compound method through wrapper' );
132+
is( $@, '', 'No errors from inherited method calls' );
133+
134+
###################################
135+
# Stateful wrapped objects
136+
###################################
137+
138+
my $counter = Counter->new;
139+
$hole->wrap( $counter, $safe, '$counter' );
140+
141+
is( $safe->reval('$counter->value()'), 0, 'Initial counter value' );
142+
is( $safe->reval('$counter->inc()'), 1, 'First increment' );
143+
is( $safe->reval('$counter->inc()'), 2, 'Second increment' );
144+
is( $safe->reval('$counter->value()'), 2, 'Value reflects increments' );
145+
is( $safe->reval('$counter->reset()'), 0, 'Reset returns 0' );
146+
is( $safe->reval('$counter->value()'), 0, 'Value after reset' );
147+
is( $@, '', 'No errors from stateful operations' );
148+
149+
###################################
150+
# wrap() without compartment args (standalone wrapping)
151+
###################################
152+
153+
{
154+
my @warnings;
155+
local $SIG{__WARN__} = sub { push @warnings, @_ };
156+
157+
my $standalone = $hole->wrap( Animal->new( name => 'Fish', sound => 'blub' ) );
158+
ok( $standalone, 'wrap() without $cpt/$name returns object' );
159+
160+
# Call methods via hole->call on the standalone wrapper
161+
is( $hole->call( sub { $standalone->name() } ), 'Fish', 'Standalone wrapped object method works via call()' );
162+
163+
# Check no warnings were produced
164+
is( scalar @warnings, 0, 'wrap() without $cpt/$name produces no warnings' )
165+
or diag("Warnings: @warnings");
166+
}
167+
168+
###################################
169+
# Multiple objects of same class in compartment
170+
###################################
171+
172+
my $safe3 = Safe->new;
173+
my $hole4 = Safe::Hole->new( {} );
174+
175+
my $a1 = Animal->new( name => 'Alpha', sound => 'aaa' );
176+
my $a2 = Animal->new( name => 'Beta', sound => 'bbb' );
177+
$hole4->wrap( $a1, $safe3, '$a1' );
178+
$hole4->wrap( $a2, $safe3, '$a2' );
179+
180+
is( $safe3->reval('$a1->name()'), 'Alpha', 'First object of same class' );
181+
is( $safe3->reval('$a2->name()'), 'Beta', 'Second object of same class' );
182+
is( $safe3->reval('$a1->sound() . $a2->sound()'), 'aaabbb', 'Both objects independent' );
183+
is( $@, '', 'No errors from multiple objects' );
184+
185+
###################################
186+
# Wrapped code ref (sub wrapping via wrap)
187+
###################################
188+
189+
my $safe4 = Safe->new;
190+
my $hole5 = Safe::Hole->new( {} );
191+
my $greeter = sub { return "hello, $_[0]" };
192+
$hole5->wrap( $greeter, $safe4, '&greet' );
193+
194+
is( $safe4->reval('greet("world")'), 'hello, world', 'Wrapped code ref callable in compartment' );
195+
is( $@, '', 'No error from wrapped code ref' );
196+
197+
###################################
198+
# Error on non-reference argument
199+
###################################
200+
201+
eval { $hole->wrap("not a reference") };
202+
like( $@, qr/reference required/, 'wrap() croaks on non-reference' );
203+
204+
###################################
205+
# Error on type mismatch: code ref with $ sigil
206+
###################################
207+
208+
eval { $hole->wrap( sub { 1 }, $safe, '$bad_name' ) };
209+
like( $@, qr/type mismatch/, 'wrap() croaks on code ref with $ sigil' );
210+
211+
###################################
212+
# Error on object with & sigil
213+
###################################
214+
215+
eval { $hole->wrap( Animal->new(), $safe, '&bad_name' ) };
216+
like( $@, qr/type mismatch/, 'wrap() croaks on object with & sigil' );
217+
218+
###################################
219+
# Error on invalid name format
220+
###################################
221+
222+
eval { $hole->wrap( sub { 1 }, $safe, 'no_sigil' ) };
223+
like( $@, qr/not a valid name/, 'wrap() croaks on name without sigil' );
224+
225+
done_testing();

0 commit comments

Comments
 (0)