lib/metaclass.pm

   1
   2 package metaclass;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed';
   9
  10 our $VERSION   = '0.04';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use Class::MOP;
  14
  15 sub import {
  16     shift;
  17     my $metaclass;
  18     if (!defined($_[0]) || $_[0] =~ /^(attribute|method|instance)_metaclass/) {
  19         $metaclass = 'Class::MOP::Class';
  20     }
  21     else {
  22         $metaclass = shift;
  23         #make sure the custom metaclass gets loaded
  24         Class::MOP::load_class($metaclass);
  25         ($metaclass->isa('Class::MOP::Class'))
  26             || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class";
  27     }
  28     my %options = @_;
  29     #make sure the custom metaclasses get loaded
  30     map{ Class::MOP::load_class($options{$_}) }
  31       grep{ /^(attribute|method|instance)_metaclass/ } keys %options;
  32     my $package = caller();
  33
  34     # create a meta object so we can install &meta
  35     my $meta = $metaclass->initialize($package => %options);
  36     $meta->add_method('meta' => sub {
  37         # we must re-initialize so that it
  38         # works as expected in subclasses,
  39         # since metaclass instances are
  40         # singletons, this is not really a
  41         # big deal anyway.
  42         $metaclass->initialize((blessed($_[0]) || $_[0]) => %options)
  43     });
  44 }
  45
  46 1;
  47
  48 __END__
  49
  50 =pod
  51
  52 =head1 NAME
  53
  54 metaclass - a pragma for installing and using Class::MOP metaclasses
  55
  56 =head1 SYNOPSIS
  57
  58   package MyClass;
  59
  60   # use Class::MOP::Class
  61   use metaclass;
  62
  63   # ... or use a custom metaclass
  64   use metaclass 'MyMetaClass';
  65
  66   # ... or use a custom metaclass
  67   # and custom attribute and method
  68   # metaclasses
  69   use metaclass 'MyMetaClass' => (
  70       'attribute_metaclass' => 'MyAttributeMetaClass',
  71       'method_metaclass'    => 'MyMethodMetaClass',
  72   );
  73
  74   # ... or just specify custom attribute
  75   # and method classes, and Class::MOP::Class
  76   # is the assumed metaclass
  77   use metaclass (
  78       'attribute_metaclass' => 'MyAttributeMetaClass',
  79       'method_metaclass'    => 'MyMethodMetaClass',
  80   );
  81
  82 =head1 DESCRIPTION
  83
  84 This is a pragma to make it easier to use a specific metaclass
  85 and a set of custom attribute and method metaclasses. It also
  86 installs a C<meta> method to your class as well.
  87
  88 =head1 AUTHORS
  89
  90 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  91
  92 =head1 COPYRIGHT AND LICENSE
  93
  94 Copyright 2006, 2007 by Infinity Interactive, Inc.
  95
  96 L<http://www.iinteractive.com>
  97
  98 This library is free software; you can redistribute it and/or modify
  99 it under the same terms as Perl itself.
 100
 101 =cut