lib/Moose.pm

   1
   2 package Moose;
   3
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.02';
   8
   9 use Scalar::Util 'blessed', 'reftype';
  10 use Carp         'confess';
  11 use Sub::Name    'subname';
  12
  13 use UNIVERSAL::require;
  14
  15 use Class::MOP;
  16
  17 use Moose::Meta::Class;
  18 use Moose::Meta::Attribute;
  19 use Moose::Meta::TypeConstraint;
  20 use Moose::Meta::TypeCoercion;
  21
  22 use Moose::Object;
  23 use Moose::Util::TypeConstraints;
  24
  25 sub import {
  26         shift;
  27         my $pkg = caller();
  28
  29         # we should never export to main
  30         return if $pkg eq 'main';
  31
  32         Moose::Util::TypeConstraints->import($pkg);
  33
  34         # make a subtype for each Moose class
  35     subtype $pkg
  36         => as Object
  37         => where { $_->isa($pkg) };
  38
  39         my $meta;
  40         if ($pkg->can('meta')) {
  41                 $meta = $pkg->meta();
  42                 (blessed($meta) && $meta->isa('Class::MOP::Class'))
  43                         || confess "Whoops, not møøsey enough";
  44         }
  45         else {
  46                 $meta = Moose::Meta::Class->initialize($pkg => (
  47                         ':attribute_metaclass' => 'Moose::Meta::Attribute'
  48                 ));
  49                 $meta->add_method('meta' => sub {
  50                         # re-initialize so it inherits properly
  51                         Moose::Meta::Class->initialize($pkg => (
  52                                 ':attribute_metaclass' => 'Moose::Meta::Attribute'
  53                         ));
  54                 })
  55         }
  56
  57         # NOTE:
  58         # &alias_method will install the method, but it
  59         # will not name it with
  60
  61         # handle superclasses
  62         $meta->alias_method('extends' => subname 'Moose::extends' => sub {
  63             $_->require for @_;
  64             $meta->superclasses(@_)
  65         });
  66
  67         # handle attributes
  68         $meta->alias_method('has' => subname 'Moose::has' => sub {
  69                 my ($name, %options) = @_;
  70                 if (exists $options{is}) {
  71                         if ($options{is} eq 'ro') {
  72                                 $options{reader} = $name;
  73                         }
  74                         elsif ($options{is} eq 'rw') {
  75                                 $options{accessor} = $name;
  76                         }
  77                 }
  78                 if (exists $options{isa}) {
  79                     # allow for anon-subtypes here ...
  80                     if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
  81                                 $options{type_constraint} = $options{isa};
  82                         }
  83                         else {
  84                             # otherwise assume it is a constraint
  85                             my $constraint = find_type_constraint($options{isa});
  86                             # if the constraing it not found ....
  87                             unless (defined $constraint) {
  88                                 # assume it is a foreign class, and make
  89                                 # an anon constraint for it
  90                                 $constraint = subtype Object => where { $_->isa($options{isa}) };
  91                             }
  92                 $options{type_constraint} = $constraint;
  93                         }
  94                 }
  95                 $meta->add_attribute($name, %options)
  96         });
  97
  98         # handle method modifers
  99         $meta->alias_method('before' => subname 'Moose::before' => sub {
 100                 my $code = pop @_;
 101                 $meta->add_before_method_modifier($_, $code) for @_;
 102         });
 103         $meta->alias_method('after'  => subname 'Moose::after' => sub {
 104                 my $code = pop @_;
 105                 $meta->add_after_method_modifier($_, $code) for @_;
 106         });
 107         $meta->alias_method('around' => subname 'Moose::around' => sub {
 108                 my $code = pop @_;
 109                 $meta->add_around_method_modifier($_, $code) for @_;
 110         });
 111
 112         # make sure they inherit from Moose::Object
 113         $meta->superclasses('Moose::Object')
 114        unless $meta->superclasses();
 115
 116         # we recommend using these things
 117         # so export them for them
 118         $meta->alias_method('confess' => \&Carp::confess);
 119         $meta->alias_method('blessed' => \&Scalar::Util::blessed);
 120 }
 121
 122 1;
 123
 124 __END__
 125
 126 =pod
 127
 128 =head1 NAME
 129
 130 Moose - Moose, it's the new Camel
 131
 132 =head1 SYNOPSIS
 133
 134   package Point;
 135   use Moose;
 136
 137   has 'x' => (isa => 'Int', is => 'rw');
 138   has 'y' => (isa => 'Int', is => 'rw');
 139
 140   sub clear {
 141       my $self = shift;
 142       $self->x(0);
 143       $self->y(0);
 144   }
 145
 146   package Point3D;
 147   use Moose;
 148
 149   extends 'Point';
 150
 151   has 'z' => (isa => 'Int');
 152
 153   after 'clear' => sub {
 154       my $self = shift;
 155       $self->{z} = 0;
 156   };
 157
 158 =head1 CAVEAT
 159
 160 This is a B<very> early release of this module, it still needs
 161 some fine tuning and B<lots> more documentation. I am adopting
 162 the I<release early and release often> approach with this module,
 163 so keep an eye on your favorite CPAN mirror!
 164
 165 =head1 DESCRIPTION
 166
 167 Moose is an extension of the Perl 5 object system.
 168
 169 =head2 Another object system!?!?
 170
 171 Yes, I know there has been an explosion recently of new ways to
 172 build object's in Perl 5, most of them based on inside-out objects,
 173 and other such things. Moose is different because it is not a new
 174 object system for Perl 5, but instead an extension of the existing
 175 object system.
 176
 177 Moose is built on top of L<Class::MOP>, which is a metaclass system
 178 for Perl 5. This means that Moose not only makes building normal
 179 Perl 5 objects better, but it also provides the power of metaclass
 180 programming.
 181
 182 =head2 What does Moose stand for??
 183
 184 Moose doesn't stand for one thing in particular, however, if you
 185 want, here are a few of my favorites, feel free to contribute
 186 more :)
 187
 188 =over 4
 189
 190 =item Make Other Object Systems Envious
 191
 192 =item Makes Object Orientation So Easy
 193
 194 =item Makes Object Orientation Spiffy- Er  (sorry ingy)
 195
 196 =item Most Other Object Systems Emasculate
 197
 198 =item My Overcraft Overfilled (with) Some Eels
 199
 200 =item Moose Often Ovulate Sorta Early
 201
 202 =item Many Overloaded Object Systems Exists
 203
 204 =item Moose Offers Often Super Extensions
 205
 206 =back
 207
 208 =head1 ACKNOWLEDGEMENTS
 209
 210 =over 4
 211
 212 =item I blame Sam Vilain for giving me my first hit of meta-model crack.
 213
 214 =item I blame Audrey Tang for encouraging that meta-crack habit in #perl6.
 215
 216 =item Without the love and encouragement of Yuval "nothingmuch" Kogman,
 217 this module would not be possible (and it wouldn't have a name).
 218
 219 =item The basis of the TypeContraints module was Rob Kinyon's idea
 220 originally, I just ran with it.
 221
 222 =item Much love to mst & chansen and the whole #moose poose for all the
 223 ideas/feature-requests/encouragement
 224
 225 =back
 226
 227 =head1 SEE ALSO
 228
 229 =over 4
 230
 231 =item L<http://forum2.org/moose/>
 232
 233 =back
 234
 235 =head1 BUGS
 236
 237 All complex software has bugs lurking in it, and this module is no
 238 exception. If you find a bug please either email me, or add the bug
 239 to cpan-RT.
 240
 241 =head1 AUTHOR
 242
 243 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 244
 245 =head1 COPYRIGHT AND LICENSE
 246
 247 Copyright 2006 by Infinity Interactive, Inc.
 248
 249 L<http://www.iinteractive.com>
 250
 251 This library is free software; you can redistribute it and/or modify
 252 it under the same terms as Perl itself.
 253
 254 =cut