lib/MooseX/ClassAttribute.pm

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