lib/Mouse.pm

   1 #!perl
   2 package Mouse;
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.01';
   7
   8 use Sub::Exporter;
   9 use Carp 'confess';
  10 use Scalar::Util 'blessed';
  11
  12 use Mouse::Meta::Attribute;
  13 use Mouse::Meta::Class;
  14 use Mouse::Object;
  15 use Mouse::TypeRegistry;
  16
  17 do {
  18     my $CALLER;
  19
  20     my %exports = (
  21         meta => sub {
  22             my $meta = Mouse::Meta::Class->initialize($CALLER);
  23             return sub { $meta };
  24         },
  25
  26         extends => sub {
  27             my $caller = $CALLER;
  28             return sub {
  29                 $caller->meta->superclasses(@_);
  30             };
  31         },
  32
  33         has => sub {
  34             return sub {
  35                 my $package = caller;
  36                 my $names = shift;
  37                 $names = [$names] if !ref($names);
  38
  39                 for my $name (@$names) {
  40                     Mouse::Meta::Attribute->create($package, $name, @_);
  41                 }
  42             };
  43         },
  44
  45         confess => sub {
  46             return \&confess;
  47         },
  48
  49         blessed => sub {
  50             return \&blessed;
  51         },
  52     );
  53
  54     my $exporter = Sub::Exporter::build_exporter({
  55         exports => \%exports,
  56         groups  => { default => [':all'] },
  57     });
  58
  59     sub import {
  60         $CALLER = caller;
  61
  62         strict->import;
  63         warnings->import;
  64
  65         my $meta = Mouse::Meta::Class->initialize($CALLER);
  66         $meta->superclasses('Mouse::Object')
  67             unless $meta->superclasses;
  68
  69         goto $exporter;
  70     }
  71
  72     sub unimport {
  73         my $caller = caller;
  74
  75         no strict 'refs';
  76         for my $keyword (keys %exports) {
  77             next if $keyword eq 'meta'; # we don't delete this one
  78             delete ${ $caller . '::' }{$keyword};
  79         }
  80     }
  81 };
  82
  83 sub load_class {
  84     my $class = shift;
  85
  86     if (ref($class) || !defined($class) || !length($class)) {
  87         my $display = defined($class) ? $class : 'undef';
  88         confess "Invalid class name ($display)";
  89     }
  90
  91     return 1 if is_class_loaded($class);
  92
  93     (my $file = "$class.pm") =~ s{::}{/}g;
  94
  95     eval { CORE::require($file) };
  96     confess "Could not load class ($class) because : $@" if $@;
  97
  98     return 1;
  99 }
 100
 101 sub is_class_loaded {
 102     my $class = shift;
 103
 104     return 0 if ref($class) || !defined($class) || !length($class);
 105
 106     # walk the symbol table tree to avoid autovififying
 107     # \*{${main::}{"Foo::"}} == \*main::Foo::
 108
 109     my $pack = \*::;
 110     foreach my $part (split('::', $class)) {
 111         return 0 unless exists ${$$pack}{"${part}::"};
 112         $pack = \*{${$$pack}{"${part}::"}};
 113     }
 114
 115     # check for $VERSION or @ISA
 116     return 1 if exists ${$$pack}{VERSION}
 117              && defined *{${$$pack}{VERSION}}{SCALAR};
 118     return 1 if exists ${$$pack}{ISA}
 119              && defined *{${$$pack}{ISA}}{ARRAY};
 120
 121     # check for any method
 122     foreach ( keys %{$$pack} ) {
 123         next if substr($_, -2, 2) eq '::';
 124         return 1 if defined *{${$$pack}{$_}}{CODE};
 125     }
 126
 127     # fail
 128     return 0;
 129 }
 130
 131 1;
 132
 133 __END__
 134
 135 =head1 NAME
 136
 137 Mouse - Moose minus antlers
 138
 139 =head1 VERSION
 140
 141 Version 0.01 released ???
 142
 143 =head1 SYNOPSIS
 144
 145     package Point;
 146     use Mouse; # automatically turns on strict and warnings
 147
 148     has 'x' => (is => 'rw', isa => 'Int');
 149     has 'y' => (is => 'rw', isa => 'Int');
 150
 151     sub clear {
 152         my $self = shift;
 153         $self->x(0);
 154         $self->y(0);
 155     }
 156
 157     package Point3D;
 158     use Mouse;
 159
 160     extends 'Point';
 161
 162     has 'z' => (is => 'rw', isa => 'Int');
 163
 164     #after 'clear' => sub {
 165     #    my $self = shift;
 166     #    $self->z(0);
 167     #};
 168
 169 =head1 DESCRIPTION
 170
 171 Moose.
 172
 173 =head1 INTERFACE
 174
 175 =head2 meta -> Mouse::Meta::Class
 176
 177 Returns this class' metaclass instance.
 178
 179 =head2 extends superclasses
 180
 181 Sets this class' superclasses.
 182
 183 =head2 has (name|names) => parameters
 184
 185 Adds an attribute (or if passed an arrayref of names, multiple attributes) to
 186 this class.
 187
 188 =head2 confess error -> BOOM
 189
 190 L<Carp/confess> for your convenience.
 191
 192 =head2 blessed value -> ClassName | undef
 193
 194 L<Scalar::Util/blessed> for your convenience.
 195
 196 =head1 MISC
 197
 198 =head2 import
 199
 200 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
 201 You may use L</extends> to replace the superclass list.
 202
 203 =head2 unimport
 204
 205 Please unimport Mouse so that if someone calls one of the keywords (such as
 206 L</extends>) it will break loudly instead breaking subtly.
 207
 208 =head1 FUNCTIONS
 209
 210 =head2 load_class Class::Name
 211
 212 This will load a given C<Class::Name> (or die if it's not loadable).
 213 This function can be used in place of tricks like
 214 C<eval "use $module"> or using C<require>.
 215
 216 =head2 is_class_loaded Class::Name -> Bool
 217
 218 Returns whether this class is actually loaded or not. It uses a heuristic which
 219 involves checking for the existence of C<$VERSION>, C<@ISA>, and any
 220 locally-defined method.
 221
 222 =head1 AUTHOR
 223
 224 Shawn M Moore, C<< <sartak at gmail.com> >>
 225
 226 =head1 BUGS
 227
 228 No known bugs.
 229
 230 Please report any bugs through RT: email
 231 C<bug-mouse at rt.cpan.org>, or browse
 232 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.
 233
 234 =head1 COPYRIGHT AND LICENSE
 235
 236 Copyright 2008 Shawn M Moore.
 237
 238 This program is free software; you can redistribute it and/or modify it
 239 under the same terms as Perl itself.
 240
 241 =cut
 242