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