Commit | Line | Data |
7adfd53f |
1 | package Reaction::Class; |
2 | |
3 | use Moose qw(confess); |
4 | use Sub::Exporter (); |
5 | use Sub::Name (); |
e739c9a2 |
6 | use Reaction::Types::Core ':all'; |
7adfd53f |
7 | use Reaction::Object; |
8 | |
9 | sub exporter_for_package { |
10 | my ($self, $package) = @_; |
11 | my %exports_proto = $self->exports_for_package($package); |
1810d302 |
12 | no warnings 'uninitialized'; # XXX fix this |
7adfd53f |
13 | my %exports = ( |
14 | map { my $cr = $exports_proto{$_}; ($_, sub { Sub::Name::subname "${self}::$_" => $cr; }) } |
15 | keys %exports_proto |
16 | ); |
17 | |
18 | my $exporter = Sub::Exporter::build_exporter({ |
19 | exports => \%exports, |
20 | groups => { |
21 | default => [':all'] |
22 | } |
23 | }); |
24 | |
25 | return $exporter; |
26 | } |
27 | |
28 | sub do_import { |
29 | my ($self, $pkg, $args) = @_; |
30 | my $exporter = $self->exporter_for_package($pkg, $args); |
31 | $exporter->($self, { into => $pkg }, @$args); |
32 | if (my @default_base = $self->default_base) { |
33 | no strict 'refs'; |
34 | @{"${pkg}::ISA"} = @default_base unless @{"${pkg}::ISA"}; |
35 | } |
36 | } |
37 | |
38 | sub default_base { ('Reaction::Object'); } |
39 | |
40 | sub exports_for_package { |
41 | my ($self, $package) = @_; |
42 | return ( |
43 | set_or_lazy_build => sub { |
44 | my $name = shift; |
45 | my $build = "build_${name}"; |
46 | return (required => 1, lazy => 1, |
47 | default => sub { shift->$build(); }); |
48 | }, |
49 | set_or_lazy_fail => sub { |
50 | my $name = shift; |
51 | my $message = "${name} must be provided before calling reader"; |
52 | return (required => 1, lazy => 1, |
53 | default => sub { confess($message); }); |
54 | }, |
55 | trigger_adopt => sub { |
56 | my $type = shift; |
57 | my @args = @_; |
58 | my $adopt = "adopt_${type}"; |
59 | return (trigger => sub { shift->$adopt(@args); }); |
60 | }, |
61 | register_inc_entry => sub { |
62 | my $inc = $package; |
63 | $inc =~ s/::/\//g; |
64 | $inc .= '.pm'; |
65 | $INC{$inc} = 1; |
66 | }, |
67 | #this needs to go away soon. its never used. pollution. |
68 | reflect_attributes_from => sub { |
69 | my ($from_class, @attrs) = @_; |
70 | |
71 | #Should we use Class::Inspector to make sure class is loaded? |
72 | #unless( Class::Inspector->loaded($from_class) ){ |
73 | # eval "require $from_class" || die("Failed to load: $from_class"); |
74 | #} |
75 | foreach my $attr_name (@attrs){ |
76 | my $from_attr = $from_class->meta->get_attribute($attr_name); |
77 | confess("$from_attr does not exist in $from_class") |
78 | unless $from_attr; |
79 | #Not happy |
80 | #$package->meta->add_attribute( $from_attr->name, %{$from_attr} ); |
81 | $package->meta->add_attribute( bless { %{$from_attr} } => |
82 | $package->meta->attribute_metaclass ); |
83 | } |
84 | }, |
85 | class => sub { |
86 | $self->do_class_sub($package, @_); |
87 | }, |
88 | does => sub { |
89 | $package->can('with')->(@_); |
90 | }, |
91 | overrides => sub { |
92 | $package->can('override')->(@_) |
93 | }, |
94 | $self->make_package_sub($package), |
95 | implements => sub { confess "implements only valid within class block" }, |
96 | $self->make_sugar_sub('is'), |
97 | $self->make_code_sugar_sub('which'), |
98 | $self->make_code_sugar_sub('as'), |
99 | run => sub (;&@) { @_ }, |
100 | ); |
101 | } |
102 | |
103 | sub do_class_sub { |
104 | my ($self, $package, $class, @args) = @_; |
105 | my $error = "Invalid class declaration, should be: class Class (is Superclass)*, which { ... }"; |
106 | confess $error if (@args % 1); |
107 | my @supers; |
108 | while (@args > 2) { |
109 | my $should_be_is = shift(@args); |
110 | confess $error unless $should_be_is eq 'is'; |
111 | push(@supers, shift(@args)); |
112 | } |
113 | confess $error unless $args[0] eq 'which' && ref($args[1]) eq 'CODE'; |
114 | my $setup = $args[1]; |
115 | |
116 | #this eval is fucked, but I can't fix it |
117 | unless ($class->can('meta')) { |
118 | print STDERR "** MAKING CLASS $class useing Reaction::Class **\n"; |
119 | eval "package ${class}; use Reaction::Class;"; |
120 | if ($@) { confess "Couldn't make ${class} a Reaction class: $@"; } |
121 | } |
122 | if (@supers) { |
123 | Class::MOP::load_class($_) for @supers; |
7adfd53f |
124 | $class->meta->superclasses(@supers); |
125 | } |
126 | $self->setup_and_cleanup($package, $setup); |
127 | |
128 | #immutable code |
129 | #print STDERR "$package \n"; |
130 | #print STDERR $package->meta->blessed, " \n"; |
131 | $package->meta->make_immutable; |
89939ff9 |
132 | # (inline_accessor => 0, inline_destructor => 0,inline_constructor => 0,); |
7adfd53f |
133 | } |
134 | |
135 | sub setup_and_cleanup { |
136 | my ($self, $package, $setup) = @_; |
137 | my @methods; |
138 | my @apply_after; |
139 | my %save_delayed; |
140 | { |
141 | no strict 'refs'; |
142 | no warnings 'redefine'; |
143 | local *{"${package}::implements"} = |
144 | Sub::Name::subname "${self}::implements" => sub { |
145 | my $name = shift; |
146 | shift if $_[0] eq 'as'; |
147 | push(@methods, [ $name, shift ]); |
148 | }; |
bf662cc3 |
149 | my $s = $setup; |
7adfd53f |
150 | foreach my $meth ($self->delayed_methods) { |
151 | $save_delayed{$meth} = $package->can($meth); |
bf662cc3 |
152 | my $s_copy = $s; |
153 | $s = sub { |
154 | local *{"${package}::${meth}"} = |
155 | Sub::Name::subname "${self}::${meth}" => sub { |
156 | push(@apply_after, [ $meth => @_ ]); |
157 | }; |
158 | $s_copy->(@_); |
159 | }; |
7adfd53f |
160 | } |
161 | # XXX - need additional fuckery to handle multi-class-per-file |
bf662cc3 |
162 | $s->(); # populate up the crap |
7adfd53f |
163 | } |
164 | my %exports = $self->exports_for_package($package); |
165 | { |
166 | no strict 'refs'; |
167 | foreach my $nuke (keys %exports) { |
168 | delete ${"${package}::"}{$nuke}; |
169 | } |
170 | } |
171 | my $unimport_class = $self->next_import_package; |
172 | eval "package ${package}; no $unimport_class;"; |
173 | confess "$unimport_class unimport from ${package} failed: $@" if $@; |
174 | foreach my $m (@methods) { |
9b2f4054 |
175 | $self->add_method_to_target($package, $m); |
7adfd53f |
176 | } |
177 | foreach my $a (@apply_after) { |
178 | my $call = shift(@$a); |
179 | $save_delayed{$call}->(@$a); |
180 | } |
181 | } |
182 | |
9b2f4054 |
183 | sub add_method_to_target { |
184 | my ($self, $target, $method) = @_; |
185 | $target->meta->add_method(@$method); |
186 | } |
187 | |
7adfd53f |
188 | sub delayed_methods { |
189 | return (qw/has with extends before after around override augment/); |
190 | } |
191 | |
192 | sub make_package_sub { |
193 | my ($self, $package) = @_; |
194 | my ($last) = (split('::', $package))[-1]; |
195 | return $last => sub { |
196 | $self->do_package_sub($package => @_); |
197 | }; |
198 | } |
199 | |
200 | sub do_package_sub { |
201 | my $self = shift; |
202 | my $package = shift; |
203 | return (@_ ? ($package => @_) : $package); |
204 | } |
205 | |
206 | sub make_sugar_sub { |
207 | my ($self, $name) = @_; |
208 | return $name => sub { |
209 | return ($name => @_); |
210 | }; |
211 | } |
212 | |
213 | sub make_code_sugar_sub { |
214 | my ($self, $name) = @_; |
215 | return $name => sub (;&@) { |
216 | return ($name => @_); |
217 | }; |
218 | } |
219 | |
220 | sub import { |
221 | my $self = shift; |
222 | my $pkg = caller; |
223 | my @args = @_; |
224 | &strict::import; |
225 | &warnings::import; |
226 | $self->do_import($pkg, \@args); |
227 | goto &{$self->next_import}; |
228 | } |
229 | |
230 | sub next_import { |
231 | return shift->next_import_package(@_)->can('import'); |
232 | } |
233 | |
234 | sub next_import_package { 'Moose' } |
235 | |
031152bc |
236 | __PACKAGE__->meta->make_immutable; |
237 | |
7adfd53f |
238 | 1; |
239 | |
240 | #---------#---------#---------#---------#---------#---------#---------#--------# |
241 | |
242 | =head1 NAME |
243 | |
244 | Reaction::Class |
245 | |
246 | =head1 DESCRIPTION |
247 | |
248 | =head1 SEE ALSO |
249 | |
250 | =over |
251 | |
252 | =item * L<Catalyst> |
253 | |
254 | =item * L<Reaction::Manual> |
255 | |
256 | =back |
257 | |
258 | =head1 Unstructured reminders |
259 | |
260 | (will properly format and stuff later. no time right now) |
261 | |
262 | C<use>ing C<Reaction::Class> will alias the current package name |
263 | see L<aliased>. |
264 | |
265 | package MyApp::Pretty::Picture |
266 | |
267 | # Picture expands to 'MyApp::Pretty::Picture' |
268 | class Picture, which { ... |
269 | |
270 | =head2 default_base |
271 | |
272 | =head2 set_or_lazy_build $attrname |
273 | |
274 | Will make your attributes lazy and required, if they are not set they |
275 | will default to the value returned by C<&build_$attrname> |
276 | |
277 | has created_d => (isa => 'DateTime', set_or_lazy_build('created_d') ); |
278 | sub build_created_d{ DateTime->now } |
279 | |
280 | =head2 set_or_lazy_fail $attrname |
281 | |
282 | Will make your attributes lazy and required, if they are not set |
283 | and their accessor is called an exception will be thrown |
284 | |
285 | =head2 trigger_adopt $attrname |
286 | |
287 | =head2 register_inc_entry |
288 | |
289 | =head2 reflect_attributes_from $from_class, @attrs |
290 | |
291 | Create attributes in the local class that mirror the specified C<@attrs> |
292 | in C<$from_class> |
293 | |
294 | =head2 class $name [, is $superclass ], which { |
295 | |
296 | Sugary class declaration, will create a a package C<$name> with an |
297 | optional base class of $superclass. The class declaration, should be placed inside |
298 | the brackets using C<implements> to declare a method and C<has> to declare an |
299 | attribute. |
300 | |
301 | =head2 does |
302 | |
303 | Alias to C<with> for the current package, see C<Moose::Role> |
304 | |
305 | =head2 implements $method_name [is | which | as] |
306 | |
307 | Only valid whithin a class block, allows you to declare a method for the class. |
308 | |
309 | implements 'current_date' => as { DateTime->today }; |
310 | |
311 | =head2 run |
312 | |
313 | =head1 AUTHORS |
314 | |
315 | =over |
316 | |
317 | =item * Matt S. Trout |
318 | |
319 | =item * K. J. Cheetham |
320 | |
321 | =item * Guillermo Roditi |
322 | |
57bc3fe3 |
323 | =item * Justin Hunter |
324 | |
7adfd53f |
325 | =item * Jess Robinson (Documentation) |
326 | |
327 | =item * Kaare Rasmussen (Documentation) |
328 | |
329 | =item * Andres N. Kievsky (Documentation) |
330 | |
c35a7a31 |
331 | =item * Robert Sedlacek (Documentation) |
332 | |
333 | =back |
334 | |
335 | =head1 SPONSORS |
336 | |
337 | =over |
338 | |
339 | =item * Ionzero |
340 | |
341 | L<Ionzero|http://www.ionzero.com/> sponsored the writing of the |
342 | L<Reaction::Manual::Tutorial>, L<Reaction::Manual::Overview> and |
343 | L<Reaction::Manual::Widgets> documentations as well as improvements |
344 | to L<Reaction::Manual::Intro> and many API documentation improvements |
345 | throughout the project. |
346 | |
7adfd53f |
347 | =back |
348 | |
349 | =head1 LICENSE |
350 | |
351 | This library is free software, you can redistribute it and/or modify |
352 | it under the same terms as Perl itself. |
353 | |
354 | =cut |