lib/MooseX/ClassAttribute.pm

   1 package MooseX::ClassAttribute;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.03';
   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->_process_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
  73         my $instance_meth = sub {
  74             no strict 'refs'; ## no critic ProhibitNoStrict
  75             return ${ $container_pkg . '::Self' } ||= shift->new(@_);
  76         };
  77
  78         my $class =
  79             Moose::Meta::Class->create
  80                 ( $container_pkg =>
  81                   superclasses => \@parents,
  82                   methods      => { instance => $instance_meth },
  83                 );
  84
  85         return $Name{$caller} = $container_pkg;
  86     }
  87
  88     sub container_class
  89     {
  90         my $pkg = shift || caller();
  91
  92         return $Name{$pkg};
  93     }
  94 }
  95
  96 # This is basically copied from Moose.pm
  97 sub unimport ## no critic RequireFinalReturn, RequireArgUnpacking
  98 {
  99     my $caller = Moose::_get_caller(@_);
 100
 101     no strict 'refs'; ## no critic ProhibitNoStrict
 102     foreach my $name (@EXPORT)
 103     {
 104         if ( defined &{ $caller . '::' . $name } )
 105         {
 106             my $keyword = \&{ $caller . '::' . $name };
 107
 108             my $pkg_name =
 109                 eval { svref_2object($keyword)->GV()->STASH()->NAME() };
 110
 111             next if $@;
 112             next if $pkg_name ne __PACKAGE__;
 113
 114             delete ${ $caller . '::' }{$name};
 115         }
 116     }
 117 }
 118
 119
 120 1;
 121
 122 __END__
 123
 124 =pod
 125
 126 =head1 NAME
 127
 128 MooseX::ClassAttribute - Declare class attributes Moose-style
 129
 130 =head1 SYNOPSIS
 131
 132     package My::Class;
 133
 134     use Moose;
 135     use MooseX::ClassAttribute;
 136
 137     class_has 'Cache' =>
 138         ( is      => 'rw',
 139           isa     => 'HashRef',
 140           default => sub { {} },
 141         );
 142
 143     __PACKAGE__->meta()->make_immutable();
 144     MooseX::ClassAttribute::containing_class()->meta()->make_immutable();
 145
 146     no Moose;
 147     no MooseX::ClassAttribute;
 148
 149     # then later ...
 150
 151     My::Class->Cache()->{thing} = ...;
 152
 153
 154 =head1 DESCRIPTION
 155
 156 This module allows you to declare class attributes in exactly the same
 157 way as you declare object attributes, except using C<class_has()>
 158 instead of C<has()>. It is also possible to make these attributes
 159 immutable (and faster) just as you can with normal Moose attributes.
 160
 161 You can use any feature of Moose's attribute declarations, including
 162 overriding a parent's attributes, delegation (C<handles>), and
 163 attribute metaclasses, and it should just work.
 164
 165 The accessors methods for class attribute may be called on the class
 166 directly, or on objects of that class. Passing a class attribute to
 167 the constructor will not set it.
 168
 169 =head1 FUNCTIONS
 170
 171 This class exports one function when you use it, C<class_has()>. This
 172 works exactly like Moose's C<has()>, but it declares class attributes.
 173
 174 Own little nit is that if you include C<no Moose> in your class, you
 175 won't remove the C<class_has()> function. To do that you must include
 176 C<no MooseX::ClassAttribute> as well.
 177
 178 If you want to use this module to create class attributes in I<other>
 179 classes, you can call the C<process_class_attribute()> function like
 180 this:
 181
 182   MooseX::ClassAttribute::process_class_attribute( $package, ... );
 183
 184 The first argument is the package which will have the class attribute,
 185 and the remaining arguments are the same as those passed to
 186 C<class_has()>.
 187
 188 =head2 Implementation and Immutability
 189
 190 Underneath the hood, this class creates one new class for each class
 191 which has class attributes and sets up delegating methods in the class
 192 for which you're creating class attributes. You don't need to worry
 193 about this too much, except when it comes to making a class immutable.
 194
 195 Since the class attributes are not really stored in your class, you
 196 need to make the containing class immutable as well as your own ...
 197
 198   __PACKAGE__->meta()->make_immutable();
 199   MooseX::ClassAttribute::containing_class()->meta()->make_immutable();
 200
 201 I<This may change in the future!>
 202
 203 =head1 AUTHOR
 204
 205 Dave Rolsky, C<< <autarch@urth.org> >>
 206
 207 =head1 BUGS
 208
 209 Please report any bugs or feature requests to
 210 C<bug-moosex-classattribute@rt.cpan.org>, or through the web interface
 211 at L<http://rt.cpan.org>.  I will be notified, and then you'll
 212 automatically be notified of progress on your bug as I make changes.
 213
 214 =head1 COPYRIGHT & LICENSE
 215
 216 Copyright 2007 Dave Rolsky, All Rights Reserved.
 217
 218 This program is free software; you can redistribute it and/or modify
 219 it under the same terms as Perl itself.
 220
 221 =cut