t/cmop/self_introspection.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Fatal;
   6
   7 use Class::MOP;
   8 use Class::MOP::Class;
   9 use Class::MOP::Package;
  10 use Class::MOP::Module;
  11
  12 {
  13     my $class = Class::MOP::Class->initialize('Foo');
  14     is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta');
  15 }
  16
  17 my $class_mop_class_meta = Class::MOP::Class->meta();
  18 isa_ok($class_mop_class_meta, 'Class::MOP::Class');
  19
  20 my $class_mop_package_meta = Class::MOP::Package->meta();
  21 isa_ok($class_mop_package_meta, 'Class::MOP::Package');
  22
  23 my $class_mop_module_meta = Class::MOP::Module->meta();
  24 isa_ok($class_mop_module_meta, 'Class::MOP::Module');
  25
  26 my @class_mop_package_methods = qw(
  27     _new
  28
  29     initialize reinitialize create create_anon is_anon
  30     _free_anon _anon_cache_key _anon_package_prefix
  31
  32     name
  33     namespace
  34
  35     add_package_symbol get_package_symbol has_package_symbol
  36     remove_package_symbol get_or_add_package_symbol
  37     list_all_package_symbols get_all_package_symbols remove_package_glob
  38
  39     _package_stash
  40
  41     get_method_map
  42
  43     DESTROY
  44 );
  45
  46 my @class_mop_module_methods = qw(
  47     _new
  48
  49     _instantiate_module
  50
  51     version authority identifier create
  52
  53     _anon_cache_key _anon_package_prefix
  54 );
  55
  56 my @class_mop_class_methods = qw(
  57     _new
  58
  59     is_pristine
  60
  61     initialize reinitialize create
  62
  63     create_anon_class is_anon_class
  64     _anon_cache_key _anon_package_prefix
  65
  66     instance_metaclass get_meta_instance
  67     _inline_create_instance
  68     _inline_rebless_instance
  69     _inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot
  70     create_meta_instance _create_meta_instance
  71     new_object clone_object
  72     _inline_new_object _inline_default_value _inline_preserve_weak_metaclasses
  73     _inline_slot_initializer _inline_extra_init _inline_fallback_constructor
  74     _inline_generate_instance _inline_params _inline_slot_initializers
  75     _inline_init_attr_from_constructor _inline_init_attr_from_default
  76     _generate_fallback_constructor
  77     construct_instance _construct_instance
  78     construct_class_instance _construct_class_instance
  79     clone_instance _clone_instance
  80     rebless_instance rebless_instance_back rebless_instance_away
  81     _force_rebless_instance _fixup_attributes_after_rebless
  82     check_metaclass_compatibility _check_metaclass_compatibility
  83     _check_class_metaclass_compatibility _check_single_metaclass_compatibility
  84     _class_metaclass_is_compatible _single_metaclass_is_compatible
  85     _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility
  86     _fix_single_metaclass_incompatibility _base_metaclasses
  87     _can_fix_metaclass_incompatibility
  88     _class_metaclass_can_be_made_compatible
  89     _single_metaclass_can_be_made_compatible
  90
  91     _remove_generated_metaobjects
  92     _restore_metaobjects_from
  93
  94     add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies
  95     add_dependent_meta_instance remove_dependent_meta_instance
  96     invalidate_meta_instances invalidate_meta_instance
  97
  98     superclasses subclasses direct_subclasses class_precedence_list
  99     linearized_isa _superclasses_updated _superclass_metas
 100
 101     alias_method get_all_method_names get_all_methods compute_all_applicable_methods
 102         find_method_by_name find_all_methods_by_name find_next_method_by_name
 103
 104         add_before_method_modifier add_after_method_modifier add_around_method_modifier
 105
 106     _attach_attribute
 107     _post_add_attribute
 108     remove_attribute
 109     find_attribute_by_name
 110     get_all_attributes
 111
 112     compute_all_applicable_attributes
 113     get_attribute_map
 114
 115     is_mutable is_immutable make_mutable make_immutable
 116     _initialize_immutable _install_inlined_code _inlined_methods
 117     _add_inlined_method _inline_accessors _inline_constructor
 118     _inline_destructor _immutable_options _real_ref_name
 119     _rebless_as_immutable _rebless_as_mutable _remove_inlined_code
 120
 121     _immutable_metaclass
 122     immutable_trait immutable_options
 123     constructor_name constructor_class destructor_class
 124 );
 125
 126 # check the class ...
 127
 128 is_deeply([ sort $class_mop_class_meta->get_method_list ], [ sort @class_mop_class_methods ], '... got the correct method list for class');
 129
 130 foreach my $method_name (sort @class_mop_class_methods) {
 131     ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')');
 132     {
 133         no strict 'refs';
 134         is($class_mop_class_meta->get_method($method_name)->body,
 135            \&{'Class::MOP::Class::' . $method_name},
 136            '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name);
 137     }
 138 }
 139
 140 ## check the package ....
 141
 142 is_deeply([ sort $class_mop_package_meta->get_method_list ], [ sort @class_mop_package_methods ], '... got the correct method list for package');
 143
 144 foreach my $method_name (sort @class_mop_package_methods) {
 145     ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')');
 146     {
 147         no strict 'refs';
 148         is($class_mop_package_meta->get_method($method_name)->body,
 149            \&{'Class::MOP::Package::' . $method_name},
 150            '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name);
 151     }
 152 }
 153
 154 ## check the module ....
 155
 156 is_deeply([ sort $class_mop_module_meta->get_method_list ], [ sort @class_mop_module_methods ], '... got the correct method list for module');
 157
 158 foreach my $method_name (sort @class_mop_module_methods) {
 159     ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')');
 160     {
 161         no strict 'refs';
 162         is($class_mop_module_meta->get_method($method_name)->body,
 163            \&{'Class::MOP::Module::' . $method_name},
 164            '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name);
 165     }
 166 }
 167
 168
 169 # check for imported functions which are not methods
 170
 171 foreach my $non_method_name (qw(
 172     confess
 173     blessed
 174     subname
 175     svref_2object
 176     )) {
 177     ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')');
 178 }
 179
 180 # check for the right attributes
 181
 182 my @class_mop_package_attributes = (
 183     'package',
 184     'namespace',
 185 );
 186
 187 my @class_mop_module_attributes = (
 188     'version',
 189     'authority'
 190 );
 191
 192 my @class_mop_class_attributes = (
 193     'superclasses',
 194     'instance_metaclass',
 195     'immutable_trait',
 196     'constructor_name',
 197     'constructor_class',
 198     'destructor_class',
 199 );
 200
 201 # check class
 202
 203 is_deeply(
 204     [ sort $class_mop_class_meta->get_attribute_list ],
 205     [ sort @class_mop_class_attributes ],
 206     '... got the right list of attributes'
 207 );
 208
 209 is_deeply(
 210     [ sort keys %{$class_mop_class_meta->_attribute_map} ],
 211     [ sort @class_mop_class_attributes ],
 212     '... got the right list of attributes');
 213
 214 foreach my $attribute_name (sort @class_mop_class_attributes) {
 215     ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')');
 216     isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
 217 }
 218
 219 # check module
 220
 221 is_deeply(
 222     [ sort $class_mop_package_meta->get_attribute_list ],
 223     [ sort @class_mop_package_attributes ],
 224     '... got the right list of attributes');
 225
 226 is_deeply(
 227     [ sort keys %{$class_mop_package_meta->_attribute_map} ],
 228     [ sort @class_mop_package_attributes ],
 229     '... got the right list of attributes');
 230
 231 foreach my $attribute_name (sort @class_mop_package_attributes) {
 232     ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')');
 233     isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
 234 }
 235
 236 # check package
 237
 238 is_deeply(
 239     [ sort $class_mop_module_meta->get_attribute_list ],
 240     [ sort @class_mop_module_attributes ],
 241     '... got the right list of attributes');
 242
 243 is_deeply(
 244     [ sort keys %{$class_mop_module_meta->_attribute_map} ],
 245     [ sort @class_mop_module_attributes ],
 246     '... got the right list of attributes');
 247
 248 foreach my $attribute_name (sort @class_mop_module_attributes) {
 249     ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')');
 250     isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
 251 }
 252
 253 ## check the attributes themselves
 254
 255 # ... package
 256
 257 ok($class_mop_package_meta->get_attribute('package')->has_reader, '... Class::MOP::Class package has a reader');
 258 is(ref($class_mop_package_meta->get_attribute('package')->reader), 'HASH', '... Class::MOP::Class package\'s a reader is { name => sub { ... } }');
 259
 260 ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg');
 261 is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package');
 262
 263 # ... class, but inherited from HasMethods
 264 ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader');
 265 is_deeply($class_mop_class_meta->find_attribute_by_name('method_metaclass')->reader,
 266    { 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass },
 267    '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass');
 268
 269 ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg');
 270 is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->init_arg,
 271   'method_metaclass',
 272   '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass');
 273
 274 ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default');
 275 is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default,
 276    'Class::MOP::Method',
 277   '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method');
 278
 279 ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader');
 280 is_deeply($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->reader,
 281    { 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass },
 282    '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass');
 283
 284 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');
 285 is($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->init_arg,
 286   'wrapped_method_metaclass',
 287   '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass');
 288
 289 ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default');
 290 is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default,
 291    'Class::MOP::Method',
 292   '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method');
 293
 294
 295 # ... class, but inherited from HasAttributes
 296
 297 ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_reader, '... Class::MOP::Class attributes has a reader');
 298 is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->reader,
 299    { '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map },
 300    '... Class::MOP::Class attributes\'s a reader is &_attribute_map');
 301
 302 ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg');
 303 is($class_mop_class_meta->find_attribute_by_name('attributes')->init_arg,
 304   'attributes',
 305   '... Class::MOP::Class attributes\'s a init_arg is attributes');
 306
 307 ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_default, '... Class::MOP::Class attributes has a default');
 308 is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->default('Foo'),
 309          {},
 310          '... Class::MOP::Class attributes\'s a default of {}');
 311
 312 ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader');
 313 is_deeply($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->reader,
 314    { 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass },
 315   '... Class::MOP::Class attribute_metaclass\'s a reader is &attribute_metaclass');
 316
 317 ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg');
 318 is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->init_arg,
 319    'attribute_metaclass',
 320    '... Class::MOP::Class attribute_metaclass\'s a init_arg is attribute_metaclass');
 321
 322 ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default');
 323 is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->default,
 324   'Class::MOP::Attribute',
 325   '... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute');
 326
 327 # check the values of some of the methods
 328
 329 is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
 330 is($class_mop_class_meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version');
 331
 332 ok($class_mop_class_meta->has_package_symbol('$VERSION'), '... Class::MOP::Class->has_package_symbol($VERSION)');
 333 is(${$class_mop_class_meta->get_package_symbol('$VERSION')},
 334    $Class::MOP::Class::VERSION,
 335    '... Class::MOP::Class->get_package_symbol($VERSION)');
 336
 337 is_deeply(
 338     [ $class_mop_class_meta->superclasses ],
 339     [ qw/Class::MOP::Module Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods/ ],
 340     '... Class::MOP::Class->superclasses == [ Class::MOP::Module ]');
 341
 342 is_deeply(
 343     [ $class_mop_class_meta->class_precedence_list ],
 344     [ qw/
 345         Class::MOP::Class
 346         Class::MOP::Module
 347         Class::MOP::Package
 348         Class::MOP::Object
 349         Class::MOP::Mixin::HasAttributes
 350         Class::MOP::Mixin
 351         Class::MOP::Mixin::HasMethods
 352         Class::MOP::Mixin
 353     / ],
 354     '... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]');
 355
 356 is($class_mop_class_meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass');
 357 is($class_mop_class_meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass');
 358 is($class_mop_class_meta->instance_metaclass, 'Class::MOP::Instance', '... got the right value for instance_metaclass');
 359
 360 done_testing;