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
|
#!/usr/bin/perl
use v5.26;
use warnings;
use Test2::V0 0.000149;
use constant HAVE_TEST_MEMORY_CYCLE => defined eval {
require Test::Memory::Cycle; Test::Memory::Cycle->import;
};
use Tangence::Constants;
use Tangence::Registry;
use Struct::Dumb 0.09; # _forbid_arrayification
use lib ".";
use t::TestObj;
$Tangence::Message::SORT_HASH_KEYS = 1;
my $registry = Tangence::Registry->new(
tanfile => "t/TestObj.tan",
);
ok( defined $registry, 'defined $registry' );
isa_ok( $registry, [ "Tangence::Registry" ], '$registry isa Tangence::Registry' );
isa_ok( $registry, [ "Tangence::Object" ], '$registry isa Tangence::Object' );
is( $registry->id, "0", '$registry->id' );
is( $registry->describe, "Tangence::Registry", '$registry->describe' );
is( $registry->get_prop_objects,
{ 0 => 'Tangence::Registry' },
'$registry objects initially has only registry' );
my $cb_self;
my $added_object_id;
$registry->subscribe_event(
object_constructed => sub { ( $cb_self, $added_object_id ) = @_ }
);
my $obj = $registry->construct(
"t::TestObj",
scalar => 12,
s_scalar => 34,
);
ok( defined $obj, 'defined $obj' );
isa_ok( $obj, [ "t::TestObj" ], '$obj isa t::TestObj' );
is_oneref( $obj, '$obj has refcount 1 initially' );
is( $obj->id, 1, '$obj->id' );
ref_is( $obj->registry, $registry, '$obj->registry' );
is( $registry->get_prop_objects,
{ 0 => Test2::Tools::Compare::string('Tangence::Registry'),
1 => Test2::Tools::Compare::string('t::TestObj[scalar=12]') },
'$registry objects now has obj too' );
ref_is( $cb_self, $registry, '$cb_self is $registry' );
is( $added_object_id, "1", '$added_object_id is 1' );
undef $cb_self;
ok( $registry->get_by_id( "1" ) == $obj, '$registry->get_by_id "1"' );
ok( !defined $registry->get_by_id( "2" ), '$registry->get_by_id "2"' );
is( $obj->describe, 't::TestObj[scalar=12]', '$obj->describe' );
# Methods
{
my $mdef = $obj->can_method( "method" );
isa_ok( $mdef, [ "Tangence::Meta::Method" ], '$obj->can_method "method"' );
is( $mdef->name, "method", 'can_method "method" name' );
is( [ map $_->sig, $mdef->argtypes ], [qw( int str )], 'can_method "method" argtypes' );
is( $mdef->ret->sig, "str", 'can_method "method" ret' );
ok( !$obj->can_method( "fly" ), '$obj->can_method "fly" is undef' );
my $methods = $obj->class->methods;
is( [ sort keys %$methods ],
[qw( method noreturn )],
'$obj->class->methods yields all' );
}
# Events
{
my $edef = $obj->can_event( "event" );
isa_ok( $edef, [ "Tangence::Meta::Event" ], '$obj->can_event "event"' );
is( $edef->name, "event", 'can_event "event" name' );
is( [ map $_->sig, $edef->argtypes ], [qw( int str )], 'can_event "event" argtypes' );
ok( $obj->can_event( "destroy" ), '$obj->can_event "destroy"' );
ok( !$obj->can_event( "flew" ), '$obj->can_event "flew" is undef' );
my $events = $obj->class->events;
is( [ sort keys %$events ],
[qw( destroy event )],
'$obj->class->events yields all' );
}
# Properties
{
my $pdef = $obj->can_property( "scalar" );
isa_ok( $pdef, [ "Tangence::Meta::Property" ], '$obj->can_property "scalar"' );
is( $pdef->name, "scalar", 'can_property "scalar" name' );
is( $pdef->dimension, DIM_SCALAR, 'can_property "scalar" dimension' );
is( $pdef->type->sig, "int", 'can_property "scalar" type' );
ok( !$obj->can_property( "style" ), '$obj->can_property "style" is undef' );
my $properties = $obj->class->properties;
is( [ sort keys %$properties ],
[qw( array hash items objset queue s_array s_scalar scalar )],
'$obj->class->properties yields all' );
is( $obj->smashkeys,
[qw( s_array s_scalar )],
'$obj->smashkeys' );
}
is_oneref( $obj, '$obj has refcount 1 just before unref' );
if(HAVE_TEST_MEMORY_CYCLE) {
no warnings 'redefine';
local *Tangence::Property::Instance::_forbid_arrayification = sub {};
memory_cycle_ok( $obj, '$obj has no memory cycles' );
memory_cycle_ok( $registry, '$registry has no memory cycles' );
}
done_testing;
|
