lib/Moose.pm

   1
   2 use lib '/Users/stevan/CPAN/Class-MOP/Class-MOP/lib';
   3
   4 package Moose;
   5
   6 use strict;
   7 use warnings;
   8
   9 our $VERSION = '0.01';
  10
  11 use Scalar::Util 'blessed', 'reftype';
  12 use Carp         'confess';
  13 use Sub::Name    'subname';
  14
  15 use Moose::Meta::Class;
  16 use Moose::Meta::Attribute;
  17
  18 use Moose::Object;
  19 use Moose::Util::TypeConstraints ':no_export';
  20
  21 sub import {
  22         shift;
  23         my $pkg = caller();
  24
  25         Moose::Util::TypeConstraints->import($pkg);
  26
  27         my $meta;
  28         if ($pkg->can('meta')) {
  29                 $meta = $pkg->meta();
  30                 (blessed($meta) && $meta->isa('Class::MOP::Class'))
  31                         || confess "Whoops, not møøsey enough";
  32         }
  33         else {
  34                 $meta = Moose::Meta::Class->initialize($pkg => (
  35                         ':attribute_metaclass' => 'Moose::Meta::Attribute'
  36                 ));
  37         }
  38
  39         # NOTE:
  40         # &alias_method will install the method, but it
  41         # will not name it with
  42
  43         # handle superclasses
  44         $meta->alias_method('extends' => subname 'Moose::extends' => sub { $meta->superclasses(@_) });
  45
  46         # handle attributes
  47         $meta->alias_method('has' => subname 'Moose::has' => sub {
  48                 my ($name, %options) = @_;
  49                 if (exists $options{is}) {
  50                         if ($options{is} eq 'ro') {
  51                                 $options{reader} = $name;
  52                         }
  53                         elsif ($options{is} eq 'rw') {
  54                                 $options{accessor} = $name;
  55                         }
  56                 }
  57                 if (exists $options{isa}) {
  58                         if (reftype($options{isa}) && reftype($options{isa}) eq 'CODE') {
  59                                 $options{type_constraint} = $options{isa};
  60                         }
  61                         else {
  62                                 $options{type_constraint} = Moose::Util::TypeConstraints::subtype(
  63                                         Object => Moose::Util::TypeConstraints::where { $_->isa($options{isa}) }
  64                                 );
  65                         }
  66                 }
  67                 $meta->add_attribute($name, %options)
  68         });
  69
  70         # handle method modifers
  71         $meta->alias_method('before' => subname 'Moose::before' => sub {
  72                 my $code = pop @_;
  73                 $meta->add_before_method_modifier($_, $code) for @_;
  74         });
  75         $meta->alias_method('after'  => subname 'Moose::after' => sub {
  76                 my $code = pop @_;
  77                 $meta->add_after_method_modifier($_, $code)  for @_;
  78         });
  79         $meta->alias_method('around' => subname 'Moose::around' => sub {
  80                 my $code = pop @_;
  81                 $meta->add_around_method_modifier($_, $code)  for @_;
  82         });
  83
  84         # make sure they inherit from Moose::Object
  85         $meta->superclasses('Moose::Object')
  86                 unless $meta->superclasses();
  87
  88         # we recommend using these things
  89         # so export them for them
  90         $meta->alias_method('confess' => \&confess);
  91         $meta->alias_method('blessed' => \&blessed);
  92 }
  93
  94 1;
  95
  96 __END__
  97
  98 =pod
  99
 100 =head1 NAME
 101
 102 Moose -
 103
 104 =head1 SYNOPSIS
 105
 106 =head1 DESCRIPTION
 107
 108 =head1 OTHER NAMES
 109
 110 Makes Other Object Systems Envious
 111
 112 Makes Object Orientation So Easy
 113
 114 =head1 BUGS
 115
 116 All complex software has bugs lurking in it, and this module is no
 117 exception. If you find a bug please either email me, or add the bug
 118 to cpan-RT.
 119
 120 =head1 CODE COVERAGE
 121
 122 I use L<Devel::Cover> to test the code coverage of my tests, below is the
 123 L<Devel::Cover> report on this module's test suite.
 124
 125 =head1 ACKNOWLEDGEMENTS
 126
 127 =head1 AUTHOR
 128
 129 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 130
 131 =head1 COPYRIGHT AND LICENSE
 132
 133 Copyright 2006 by Infinity Interactive, Inc.
 134
 135 L<http://www.iinteractive.com>
 136
 137 This library is free software; you can redistribute it and/or modify
 138 it under the same terms as Perl itself.
 139
 140 =cut