File: 010_self_introspection.t

package info (click to toggle)
libclass-mop-perl 1.04-1
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 1,244 kB
  • ctags: 1,272
  • sloc: perl: 5,192; ansic: 241; makefile: 2
file content (347 lines) | stat: -rw-r--r-- 14,085 bytes parent folder | download
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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
use strict;
use warnings;

use Test::More;
use Test::Exception;

use Class::MOP;
use Class::MOP::Class;
use Class::MOP::Package;
use Class::MOP::Module;

{
    my $class = Class::MOP::Class->initialize('Foo');
    is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta');
}

my $class_mop_class_meta = Class::MOP::Class->meta();
isa_ok($class_mop_class_meta, 'Class::MOP::Class');

my $class_mop_package_meta = Class::MOP::Package->meta();
isa_ok($class_mop_package_meta, 'Class::MOP::Package');

my $class_mop_module_meta = Class::MOP::Module->meta();
isa_ok($class_mop_module_meta, 'Class::MOP::Module');

my @class_mop_package_methods = qw(
    _new

    initialize reinitialize

    name
    namespace

    add_package_symbol get_package_symbol has_package_symbol remove_package_symbol
    list_all_package_symbols get_all_package_symbols remove_package_glob

    _package_stash

    get_method_map
);

my @class_mop_module_methods = qw(
    _new

    _instantiate_module

    version authority identifier create
);

my @class_mop_class_methods = qw(
    _new

    is_pristine

    initialize create

    update_package_cache_flag
    reset_package_cache_flag

    create_anon_class is_anon_class

    instance_metaclass get_meta_instance
    create_meta_instance _create_meta_instance
    new_object clone_object
    construct_instance _construct_instance
    construct_class_instance _construct_class_instance
    clone_instance _clone_instance
    rebless_instance rebless_instance_back rebless_instance_away
    check_metaclass_compatibility _check_metaclass_compatibility
    _check_class_metaclass_compatibility _check_single_metaclass_compatibility
    _class_metaclass_is_compatible _single_metaclass_is_compatible
    _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility
    _fix_single_metaclass_incompatibility _base_metaclasses
    _can_fix_class_metaclass_incompatibility_by_subclassing
    _can_fix_single_metaclass_incompatibility_by_subclassing
    _can_fix_metaclass_incompatibility_by_subclassing
    _can_fix_metaclass_incompatibility

    add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies
    add_dependent_meta_instance remove_dependent_meta_instance
    invalidate_meta_instances invalidate_meta_instance

    superclasses subclasses direct_subclasses class_precedence_list
    linearized_isa _superclasses_updated

    alias_method get_all_method_names get_all_methods compute_all_applicable_methods
        find_method_by_name find_all_methods_by_name find_next_method_by_name

        add_before_method_modifier add_after_method_modifier add_around_method_modifier

    _attach_attribute
    _post_add_attribute
    remove_attribute
    find_attribute_by_name
    get_all_attributes

    compute_all_applicable_attributes
    get_attribute_map

    is_mutable is_immutable make_mutable make_immutable
    _initialize_immutable _install_inlined_code _inlined_methods
    _add_inlined_method _inline_accessors _inline_constructor
    _inline_destructor _immutable_options _real_ref_name
    _rebless_as_immutable _rebless_as_mutable _remove_inlined_code

    _immutable_metaclass
    immutable_trait immutable_options
    constructor_name constructor_class destructor_class

    DESTROY
);

# check the class ...

is_deeply([ sort $class_mop_class_meta->get_method_list ], [ sort @class_mop_class_methods ], '... got the correct method list for class');

foreach my $method_name (sort @class_mop_class_methods) {
    ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')');
    {
        no strict 'refs';
        is($class_mop_class_meta->get_method($method_name)->body,
           \&{'Class::MOP::Class::' . $method_name},
           '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name);
    }
}

## check the package ....

is_deeply([ sort $class_mop_package_meta->get_method_list ], [ sort @class_mop_package_methods ], '... got the correct method list for package');

foreach my $method_name (sort @class_mop_package_methods) {
    ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')');
    {
        no strict 'refs';
        is($class_mop_package_meta->get_method($method_name)->body,
           \&{'Class::MOP::Package::' . $method_name},
           '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name);
    }
}

## check the module ....

is_deeply([ sort $class_mop_module_meta->get_method_list ], [ sort @class_mop_module_methods ], '... got the correct method list for module');

foreach my $method_name (sort @class_mop_module_methods) {
    ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')');
    {
        no strict 'refs';
        is($class_mop_module_meta->get_method($method_name)->body,
           \&{'Class::MOP::Module::' . $method_name},
           '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name);
    }
}


# check for imported functions which are not methods

foreach my $non_method_name (qw(
    confess
    blessed
    subname
    svref_2object
    )) {
    ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')');
}

# check for the right attributes

my @class_mop_package_attributes = (
    'package',
    'namespace',
);

my @class_mop_module_attributes = (
    'version',
    'authority'
);

my @class_mop_class_attributes = (
    'superclasses',
    'instance_metaclass',
    'immutable_trait',
    'constructor_name',
    'constructor_class',
    'destructor_class',
);

# check class

is_deeply(
    [ sort $class_mop_class_meta->get_attribute_list ],
    [ sort @class_mop_class_attributes ],
    '... got the right list of attributes'
);

is_deeply(
    [ sort keys %{$class_mop_class_meta->_attribute_map} ],
    [ sort @class_mop_class_attributes ],
    '... got the right list of attributes');

foreach my $attribute_name (sort @class_mop_class_attributes) {
    ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')');
    isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
}

# check module

is_deeply(
    [ sort $class_mop_package_meta->get_attribute_list ],
    [ sort @class_mop_package_attributes ],
    '... got the right list of attributes');

is_deeply(
    [ sort keys %{$class_mop_package_meta->_attribute_map} ],
    [ sort @class_mop_package_attributes ],
    '... got the right list of attributes');

foreach my $attribute_name (sort @class_mop_package_attributes) {
    ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')');
    isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
}

# check package

is_deeply(
    [ sort $class_mop_module_meta->get_attribute_list ],
    [ sort @class_mop_module_attributes ],
    '... got the right list of attributes');

is_deeply(
    [ sort keys %{$class_mop_module_meta->_attribute_map} ],
    [ sort @class_mop_module_attributes ],
    '... got the right list of attributes');

foreach my $attribute_name (sort @class_mop_module_attributes) {
    ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')');
    isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
}

## check the attributes themselves

# ... package

ok($class_mop_package_meta->get_attribute('package')->has_reader, '... Class::MOP::Class package has a reader');
is(ref($class_mop_package_meta->get_attribute('package')->reader), 'HASH', '... Class::MOP::Class package\'s a reader is { name => sub { ... } }');

ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg');
is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package');

# ... class, but inherited from HasMethods
ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader');
is_deeply($class_mop_class_meta->find_attribute_by_name('method_metaclass')->reader,
   { 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass },
   '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass');

ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg');
is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->init_arg,
  'method_metaclass',
  '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass');

ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default');
is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default,
   'Class::MOP::Method',
  '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method');

ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader');
is_deeply($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->reader,
   { 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass },
   '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass');

ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Class wrapped_method_metaclass has a init_arg');
is($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->init_arg,
  'wrapped_method_metaclass',
  '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass');

ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default');
is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default,
   'Class::MOP::Method',
  '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method');


# ... class, but inherited from HasAttributes

ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_reader, '... Class::MOP::Class attributes has a reader');
is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->reader,
   { '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map },
   '... Class::MOP::Class attributes\'s a reader is &_attribute_map');

ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg');
is($class_mop_class_meta->find_attribute_by_name('attributes')->init_arg,
  'attributes',
  '... Class::MOP::Class attributes\'s a init_arg is attributes');

ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_default, '... Class::MOP::Class attributes has a default');
is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->default('Foo'),
         {},
         '... Class::MOP::Class attributes\'s a default of {}');

ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader');
is_deeply($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->reader,
   { 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass },
  '... Class::MOP::Class attribute_metaclass\'s a reader is &attribute_metaclass');

ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg');
is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->init_arg,
   'attribute_metaclass',
   '... Class::MOP::Class attribute_metaclass\'s a init_arg is attribute_metaclass');

ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default');
is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->default,
  'Class::MOP::Attribute',
  '... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute');

# check the values of some of the methods

is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
is($class_mop_class_meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version');

ok($class_mop_class_meta->has_package_symbol('$VERSION'), '... Class::MOP::Class->has_package_symbol($VERSION)');
is(${$class_mop_class_meta->get_package_symbol('$VERSION')},
   $Class::MOP::Class::VERSION,
   '... Class::MOP::Class->get_package_symbol($VERSION)');

is_deeply(
    [ $class_mop_class_meta->superclasses ],
    [ qw/Class::MOP::Module Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods/ ],
    '... Class::MOP::Class->superclasses == [ Class::MOP::Module ]');

is_deeply(
    [ $class_mop_class_meta->class_precedence_list ],
    [ qw/
        Class::MOP::Class
        Class::MOP::Module
        Class::MOP::Package
        Class::MOP::Object
        Class::MOP::Mixin::HasAttributes
        Class::MOP::Mixin
        Class::MOP::Mixin::HasMethods
        Class::MOP::Mixin
    / ],
    '... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]');

is($class_mop_class_meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass');
is($class_mop_class_meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass');
is($class_mop_class_meta->instance_metaclass, 'Class::MOP::Instance', '... got the right value for instance_metaclass');

done_testing;