lib/MooseX/ClassAttribute.pm

   1 package MooseX::ClassAttribute;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.04';
   7 our $AUTHORITY = 'cpan:DROLSKY';
   8
   9 our @EXPORT = 'class_has'; ## no critic ProhibitAutomaticExportation
  10 use base 'Exporter';
  11
  12 use B qw( svref_2object );
  13 use Moose::Meta::Class;
  14 use Sub::Name;
  15
  16
  17 sub class_has ## no critic RequireArgUnpacking
  18 {
  19     my $caller = caller();
  20
  21     process_class_attribute( $caller, @_ );
  22
  23     return;
  24 }
  25
  26 sub process_class_attribute ## no critic RequireArgUnpacking
  27 {
  28     my $caller = shift;
  29
  30     my $caller_meta = $caller->meta();
  31
  32     my @parents = $caller_meta->superclasses();
  33
  34     my $container_pkg = _make_container_class( $caller, @parents );
  35     my $container_meta = $container_pkg->meta();
  36
  37     $container_meta->add_attribute(@_);
  38
  39     for my $meth ( grep { $_ ne 'instance' } $container_meta->get_method_list() )
  40     {
  41         next if $caller_meta->has_method($meth);
  42
  43         my $sub = sub { shift;
  44                         my $instance = $container_pkg->instance();
  45                         return $instance->$meth(@_); };
  46
  47         $caller_meta->add_method( $meth => $sub );
  48     }
  49
  50     return;
  51 }
  52
  53 {
  54     # This should probably be an attribute of the metaclass, but that
  55     # would require extending Moose::Meta::Class, which would conflict
  56     # with anything else that wanted to do so as well (we need
  57     # metaclass roles or something).
  58     my %Name;
  59
  60     sub _make_container_class ## no critic RequireArgUnpacking
  61     {
  62         my $caller  = shift;
  63
  64         return $Name{$caller} if $Name{$caller};
  65
  66         my @parents = map { container_class($_) || () } @_;
  67
  68         push @parents, 'Moose::Object'
  69             unless grep { $_->isa('Moose::Object') } @parents;
  70
  71         my $container_pkg = 'MooseX::ClassAttribute::Container::' . $caller;
  72         my $instance_holder = $container_pkg . '::Self';
  73
  74         my $instance_meth = sub {
  75             no strict 'refs'; ## no critic ProhibitNoStrict
  76             return $$instance_holder ||= shift->new(@_);
  77         };
  78
  79         my $class =
  80             Moose::Meta::Class->create
  81                 ( $container_pkg =>
  82                   superclasses => \@parents,
  83                   methods      => { instance => $instance_meth },
  84                 );
  85
  86         return $Name{$caller} = $container_pkg;
  87     }
  88
  89     sub container_class
  90     {
  91         my $pkg = shift || caller();
  92
  93         return $Name{$pkg};
  94     }
  95 }
  96
  97 # This is basically copied from Moose.pm
  98 sub unimport ## no critic RequireFinalReturn, RequireArgUnpacking
  99 {
 100     my $caller = Moose::_get_caller(@_);
 101
 102     no strict 'refs'; ## no critic ProhibitNoStrict
 103     foreach my $name (@EXPORT)
 104     {
 105         if ( defined &{ $caller . '::' . $name } )
 106         {
 107             my $keyword = \&{ $caller . '::' . $name };
 108
 109             my $pkg_name =
 110                 eval { svref_2object($keyword)->GV()->STASH()->NAME() };
 111
 112             next if $@;
 113             next if $pkg_name ne __PACKAGE__;
 114
 115             delete ${ $caller . '::' }{$name};
 116         }
 117     }
 118 }
 119
 120
 121 1;
 122
 123 __END__
 124
 125 =pod
 126
 127 =head1 NAME
 128
 129 MooseX::ClassAttribute - Declare class attributes Moose-style
 130
 131 =head1 SYNOPSIS
 132
 133     package My::Class;
 134
 135     use Moose;
 136     use MooseX::ClassAttribute;
 137
 138     class_has 'Cache' =>
 139         ( is      => 'rw',
 140           isa     => 'HashRef',
 141           default => sub { {} },
 142         );
 143
 144     __PACKAGE__->meta()->make_immutable();
 145     MooseX::ClassAttribute::container_class()->meta()->make_immutable();
 146
 147     no Moose;
 148     no MooseX::ClassAttribute;
 149
 150     # then later ...
 151
 152     My::Class->Cache()->{thing} = ...;
 153
 154
 155 =head1 DESCRIPTION
 156
 157 This module allows you to declare class attributes in exactly the same
 158 way as you declare object attributes, except using C<class_has()>
 159 instead of C<has()>. It is also possible to make these attributes
 160 immutable (and faster) just as you can with normal Moose attributes.
 161
 162 You can use any feature of Moose's attribute declarations, including
 163 overriding a parent's attributes, delegation (C<handles>), and
 164 attribute metaclasses, and it should just work.
 165
 166 The accessors methods for class attribute may be called on the class
 167 directly, or on objects of that class. Passing a class attribute to
 168 the constructor will not set it.
 169
 170 =head1 FUNCTIONS
 171
 172 This class exports one function when you use it, C<class_has()>. This
 173 works exactly like Moose's C<has()>, but it declares class attributes.
 174
 175 One little nit is that if you include C<no Moose> in your class, you
 176 won't remove the C<class_has()> function. To do that you must include
 177 C<no MooseX::ClassAttribute> as well.
 178
 179 If you want to use this module to create class attributes in I<other>
 180 classes, you can call the C<process_class_attribute()> function like
 181 this:
 182
 183   MooseX::ClassAttribute::process_class_attribute( $package, ... );
 184
 185 The first argument is the package which will have the class attribute,
 186 and the remaining arguments are the same as those passed to
 187 C<class_has()>.
 188
 189 =head2 Implementation and Immutability
 190
 191 Underneath the hood, this class creates one new class for each class
 192 which has class attributes and sets up delegating methods in the class
 193 for which you're creating class attributes. You don't need to worry
 194 about this too much, except when it comes to making a class immutable.
 195
 196 Since the class attributes are not really stored in your class, you
 197 need to make the container class immutable as well as your own ...
 198
 199   __PACKAGE__->meta()->make_immutable();
 200   MooseX::ClassAttribute::container_class()->meta()->make_immutable();
 201
 202 I<This may change in the future!>
 203
 204 =head1 AUTHOR
 205
 206 Dave Rolsky, C<< <autarch@urth.org> >>
 207
 208 =head1 BUGS
 209
 210 Please report any bugs or feature requests to
 211 C<bug-moosex-classattribute@rt.cpan.org>, or through the web interface
 212 at L<http://rt.cpan.org>.  I will be notified, and then you'll
 213 automatically be notified of progress on your bug as I make changes.
 214
 215 =head1 COPYRIGHT & LICENSE
 216
 217 Copyright 2007 Dave Rolsky, All Rights Reserved.
 218
 219 This program is free software; you can redistribute it and/or modify
 220 it under the same terms as Perl itself.
 221
 222 =cut