lib/MooseX/ClassAttribute.pm

   1 package MooseX::ClassAttribute;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.01';
   7 our $AUTHORITY = 'cpan:DROLSKY';
   8
   9 our @EXPORT = 'class_has'; ## no critic ProhibitAutomaticExportation
  10 use Exporter qw( import );
  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 =head1 FUNCTIONS
 163
 164 This class exports one function when you use it, C<class_has()>. This
 165 works exactly like Moose's C<has()>, but it declares class attributes.
 166
 167 Own little nit is that if you include C<no Moose> in your class, you
 168 won't remove the C<class_has()> function. To do that you must include
 169 C<no MooseX::ClassAttribute> as well.
 170
 171 =head2 Implementation and Immutability
 172
 173 Underneath the hood, this class creates one new class for each class
 174 which has class attributes and sets up delegating methods in the class
 175 for which you're creating class attributes. You don't need to worry
 176 about this too much, except when it comes to making a class immutable.
 177
 178 Since the class attributes are not really stored in your class, you
 179 need to make the containing class immutable as well as your own ...
 180
 181   __PACKAGE__->meta()->make_immutable();
 182   MooseX::ClassAttribute::containing_class()->meta()->make_immutable();
 183
 184 I<This may change in the future!>
 185
 186 =head1 AUTHOR
 187
 188 Dave Rolsky, C<< <autarch@urth.org> >>
 189
 190 =head1 BUGS
 191
 192 Please report any bugs or feature requests to
 193 C<bug-moosex-classattribute@rt.cpan.org>, or through the web interface
 194 at L<http://rt.cpan.org>.  I will be notified, and then you'll
 195 automatically be notified of progress on your bug as I make changes.
 196
 197 =head1 COPYRIGHT & LICENSE
 198
 199 Copyright 2007 Dave Rolsky, All Rights Reserved.
 200
 201 This program is free software; you can redistribute it and/or modify
 202 it under the same terms as Perl itself.
 203
 204 =cut