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