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';
  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                         $options{type_constraint} = $options{is};
  52                 }
  53                 elsif (exists $options{isa}) {
  54                         $options{type_constraint} = Moose::Util::TypeConstraints::subtype(
  55                                 Object => Moose::Util::TypeConstraints::where { $_->isa($options{isa}) }
  56                         );
  57                 }
  58                 $meta->add_attribute($name, %options)
  59         });
  60
  61         # handle method modifers
  62         $meta->alias_method('before' => subname 'Moose::before' => sub {
  63                 my $code = pop @_;
  64                 $meta->add_before_method_modifier($_, $code) for @_;
  65         });
  66         $meta->alias_method('after'  => subname 'Moose::after' => sub {
  67                 my $code = pop @_;
  68                 $meta->add_after_method_modifier($_, $code)  for @_;
  69         });
  70         $meta->alias_method('around' => subname 'Moose::around' => sub {
  71                 my $code = pop @_;
  72                 $meta->add_around_method_modifier($_, $code)  for @_;
  73         });
  74
  75         # make sure they inherit from Moose::Object
  76         $meta->superclasses('Moose::Object')
  77                 unless $meta->superclasses();
  78
  79         # we recommend using these things
  80         # so export them for them
  81         $meta->alias_method('confess' => \&confess);
  82         $meta->alias_method('blessed' => \&blessed);
  83 }
  84
  85 1;
  86
  87 __END__
  88
  89 =pod
  90
  91 =head1 NAME
  92
  93 Moose -
  94
  95 =head1 SYNOPSIS
  96
  97 =head1 DESCRIPTION
  98
  99 =head1 OTHER NAMES
 100
 101 Makes Other Object Systems Envious
 102
 103 Most Other Objects Suck Eggs
 104
 105 Makes Object Orientation So Easy
 106
 107 Metacircular Object Oriented Systems Environment
 108
 109 =head1 BUGS
 110
 111 All complex software has bugs lurking in it, and this module is no
 112 exception. If you find a bug please either email me, or add the bug
 113 to cpan-RT.
 114
 115 =head1 CODE COVERAGE
 116
 117 I use L<Devel::Cover> to test the code coverage of my tests, below is the
 118 L<Devel::Cover> report on this module's test suite.
 119
 120 =head1 ACKNOWLEDGEMENTS
 121
 122 =head1 AUTHOR
 123
 124 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 125
 126 =head1 COPYRIGHT AND LICENSE
 127
 128 Copyright 2006 by Infinity Interactive, Inc.
 129
 130 L<http://www.iinteractive.com>
 131
 132 This library is free software; you can redistribute it and/or modify
 133 it under the same terms as Perl itself.
 134
 135 =cut