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