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.03';
  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         Class::MOP::load_class($metaclass);
  24         ($metaclass->isa('Class::MOP::Class'))
  25             || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class";
  26     }
  27     my %options = @_;
  28     my $package = caller();
  29
  30     # create a meta object so we can install &meta
  31     my $meta = $metaclass->initialize($package => %options);
  32     $meta->add_method('meta' => sub {
  33         # we must re-initialize so that it
  34         # works as expected in subclasses,
  35         # since metaclass instances are
  36         # singletons, this is not really a
  37         # big deal anyway.
  38         $metaclass->initialize((blessed($_[0]) || $_[0]) => %options)
  39     });
  40 }
  41
  42 1;
  43
  44 __END__
  45
  46 =pod
  47
  48 =head1 NAME
  49
  50 metaclass - a pragma for installing and using Class::MOP metaclasses
  51
  52 =head1 SYNOPSIS
  53
  54   package MyClass;
  55
  56   # use Class::MOP::Class
  57   use metaclass;
  58
  59   # ... or use a custom metaclass
  60   use metaclass 'MyMetaClass';
  61
  62   # ... or use a custom metaclass
  63   # and custom attribute and method
  64   # metaclasses
  65   use metaclass 'MyMetaClass' => (
  66       'attribute_metaclass' => 'MyAttributeMetaClass',
  67       'method_metaclass'    => 'MyMethodMetaClass',
  68   );
  69
  70   # ... or just specify custom attribute
  71   # and method classes, and Class::MOP::Class
  72   # is the assumed metaclass
  73   use metaclass (
  74       'attribute_metaclass' => 'MyAttributeMetaClass',
  75       'method_metaclass'    => 'MyMethodMetaClass',
  76   );
  77
  78 =head1 DESCRIPTION
  79
  80 This is a pragma to make it easier to use a specific metaclass
  81 and a set of custom attribute and method metaclasses. It also
  82 installs a C<meta> method to your class as well.
  83
  84 =head1 AUTHORS
  85
  86 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  87
  88 =head1 COPYRIGHT AND LICENSE
  89
  90 Copyright 2006, 2007 by Infinity Interactive, Inc.
  91
  92 L<http://www.iinteractive.com>
  93
  94 This library is free software; you can redistribute it and/or modify
  95 it under the same terms as Perl itself.
  96
  97 =cut