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