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