Commit | Line | Data |
c3398f5b |
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 | |
306290e8 |
12 | use Mouse::Meta::Attribute; |
13 | use Mouse::Meta::Class; |
c3398f5b |
14 | use Mouse::Object; |
d60c78b9 |
15 | use Mouse::TypeRegistry; |
c3398f5b |
16 | |
17 | do { |
18 | my $CALLER; |
19 | |
20 | my %exports = ( |
21 | meta => sub { |
306290e8 |
22 | my $meta = Mouse::Meta::Class->initialize($CALLER); |
c3398f5b |
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) { |
306290e8 |
40 | Mouse::Meta::Attribute->create($package, $name, @_); |
c3398f5b |
41 | } |
42 | }; |
43 | }, |
44 | |
45 | confess => sub { |
b17094ce |
46 | return \&confess; |
c3398f5b |
47 | }, |
48 | |
49 | blessed => sub { |
b17094ce |
50 | return \&blessed; |
c3398f5b |
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 | |
306290e8 |
65 | my $meta = Mouse::Meta::Class->initialize($CALLER); |
ca73a208 |
66 | $meta->superclasses('Mouse::Object') |
67 | unless $meta->superclasses; |
c3398f5b |
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; |
79af4b55 |
85 | return if ref($class); |
86 | return unless defined($class) && length($class); |
c3398f5b |
87 | |
2a674d23 |
88 | return 1 if is_class_loaded($class); |
89 | |
c3398f5b |
90 | (my $file = "$class.pm") =~ s{::}{/}g; |
91 | |
92 | eval { CORE::require($file) }; |
2a674d23 |
93 | confess "Could not load class ($class) because : $@" if $@; |
c3398f5b |
94 | |
95 | return 1; |
96 | } |
97 | |
2a674d23 |
98 | sub is_class_loaded { |
99 | my $class = shift; |
100 | |
7ecc2123 |
101 | return 0 if ref($class) || !defined($class) || !length($class); |
102 | |
bf134049 |
103 | # walk the symbol table tree to avoid autovififying |
104 | # \*{${main::}{"Foo::"}} == \*main::Foo:: |
105 | |
106 | my $pack = \*::; |
107 | foreach my $part (split('::', $class)) { |
108 | return 0 unless exists ${$$pack}{"${part}::"}; |
109 | $pack = \*{${$$pack}{"${part}::"}}; |
2a674d23 |
110 | } |
bf134049 |
111 | |
112 | # check for $VERSION or @ISA |
113 | return 1 if exists ${$$pack}{VERSION} |
114 | && defined *{${$$pack}{VERSION}}{SCALAR}; |
115 | return 1 if exists ${$$pack}{ISA} |
116 | && defined *{${$$pack}{ISA}}{ARRAY}; |
117 | |
118 | # check for any method |
119 | foreach ( keys %{$$pack} ) { |
120 | next if substr($_, -2, 2) eq '::'; |
121 | return 1 if defined *{${$$pack}{$_}}{CODE}; |
122 | } |
123 | |
124 | # fail |
2a674d23 |
125 | return 0; |
126 | } |
127 | |
c3398f5b |
128 | 1; |
129 | |
130 | __END__ |
131 | |
132 | =head1 NAME |
133 | |
6caea456 |
134 | Mouse - Moose minus antlers |
c3398f5b |
135 | |
136 | =head1 VERSION |
137 | |
138 | Version 0.01 released ??? |
139 | |
140 | =head1 SYNOPSIS |
141 | |
142 | package Point; |
6caea456 |
143 | use Mouse; # automatically turns on strict and warnings |
144 | |
145 | has 'x' => (is => 'rw', isa => 'Int'); |
146 | has 'y' => (is => 'rw', isa => 'Int'); |
147 | |
148 | sub clear { |
149 | my $self = shift; |
150 | $self->x(0); |
151 | $self->y(0); |
152 | } |
153 | |
154 | package Point3D; |
c3398f5b |
155 | use Mouse; |
156 | |
6caea456 |
157 | extends 'Point'; |
c3398f5b |
158 | |
6caea456 |
159 | has 'z' => (is => 'rw', isa => 'Int'); |
160 | |
161 | #after 'clear' => sub { |
162 | # my $self = shift; |
163 | # $self->z(0); |
164 | #}; |
c3398f5b |
165 | |
166 | =head1 DESCRIPTION |
167 | |
168 | Moose. |
169 | |
170 | =head1 INTERFACE |
171 | |
306290e8 |
172 | =head2 meta -> Mouse::Meta::Class |
c3398f5b |
173 | |
174 | Returns this class' metaclass instance. |
175 | |
176 | =head2 extends superclasses |
177 | |
178 | Sets this class' superclasses. |
179 | |
180 | =head2 has (name|names) => parameters |
181 | |
182 | Adds an attribute (or if passed an arrayref of names, multiple attributes) to |
183 | this class. |
184 | |
185 | =head2 confess error -> BOOM |
186 | |
187 | L<Carp/confess> for your convenience. |
188 | |
189 | =head2 blessed value -> ClassName | undef |
190 | |
191 | L<Scalar::Util/blessed> for your convenience. |
192 | |
193 | =head1 MISC |
194 | |
195 | =head2 import |
196 | |
6caea456 |
197 | Importing Mouse will default your class' superclass list to L<Mouse::Object>. |
c3398f5b |
198 | You may use L</extends> to replace the superclass list. |
199 | |
200 | =head2 unimport |
201 | |
202 | Please unimport Mouse so that if someone calls one of the keywords (such as |
203 | L</extends>) it will break loudly instead breaking subtly. |
204 | |
205 | =head1 FUNCTIONS |
206 | |
207 | =head2 load_class Class::Name |
208 | |
6caea456 |
209 | This will load a given C<Class::Name> (or die if it's not loadable). |
c3398f5b |
210 | This function can be used in place of tricks like |
211 | C<eval "use $module"> or using C<require>. |
212 | |
213 | =head1 AUTHOR |
214 | |
215 | Shawn M Moore, C<< <sartak at gmail.com> >> |
216 | |
217 | =head1 BUGS |
218 | |
219 | No known bugs. |
220 | |
221 | Please report any bugs through RT: email |
222 | C<bug-mouse at rt.cpan.org>, or browse |
223 | L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>. |
224 | |
225 | =head1 COPYRIGHT AND LICENSE |
226 | |
227 | Copyright 2008 Shawn M Moore. |
228 | |
229 | This program is free software; you can redistribute it and/or modify it |
230 | under the same terms as Perl itself. |
231 | |
232 | =cut |
233 | |