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; |
124 | $class->meta->_fix_metaclass_incompatability(@supers); |
125 | $class->meta->superclasses(@supers); |
126 | } |
127 | $self->setup_and_cleanup($package, $setup); |
128 | |
129 | #immutable code |
130 | #print STDERR "$package \n"; |
131 | #print STDERR $package->meta->blessed, " \n"; |
132 | $package->meta->make_immutable; |
89939ff9 |
133 | # (inline_accessor => 0, inline_destructor => 0,inline_constructor => 0,); |
7adfd53f |
134 | } |
135 | |
136 | sub setup_and_cleanup { |
137 | my ($self, $package, $setup) = @_; |
138 | my @methods; |
139 | my @apply_after; |
140 | my %save_delayed; |
141 | { |
142 | no strict 'refs'; |
143 | no warnings 'redefine'; |
144 | local *{"${package}::implements"} = |
145 | Sub::Name::subname "${self}::implements" => sub { |
146 | my $name = shift; |
147 | shift if $_[0] eq 'as'; |
148 | push(@methods, [ $name, shift ]); |
149 | }; |
bf662cc3 |
150 | my $s = $setup; |
7adfd53f |
151 | foreach my $meth ($self->delayed_methods) { |
152 | $save_delayed{$meth} = $package->can($meth); |
bf662cc3 |
153 | my $s_copy = $s; |
154 | $s = sub { |
155 | local *{"${package}::${meth}"} = |
156 | Sub::Name::subname "${self}::${meth}" => sub { |
157 | push(@apply_after, [ $meth => @_ ]); |
158 | }; |
159 | $s_copy->(@_); |
160 | }; |
7adfd53f |
161 | } |
162 | # XXX - need additional fuckery to handle multi-class-per-file |
bf662cc3 |
163 | $s->(); # populate up the crap |
7adfd53f |
164 | } |
165 | my %exports = $self->exports_for_package($package); |
166 | { |
167 | no strict 'refs'; |
168 | foreach my $nuke (keys %exports) { |
169 | delete ${"${package}::"}{$nuke}; |
170 | } |
171 | } |
172 | my $unimport_class = $self->next_import_package; |
173 | eval "package ${package}; no $unimport_class;"; |
174 | confess "$unimport_class unimport from ${package} failed: $@" if $@; |
175 | foreach my $m (@methods) { |
9b2f4054 |
176 | $self->add_method_to_target($package, $m); |
7adfd53f |
177 | } |
178 | foreach my $a (@apply_after) { |
179 | my $call = shift(@$a); |
180 | $save_delayed{$call}->(@$a); |
181 | } |
182 | } |
183 | |
9b2f4054 |
184 | sub add_method_to_target { |
185 | my ($self, $target, $method) = @_; |
186 | $target->meta->add_method(@$method); |
187 | } |
188 | |
7adfd53f |
189 | sub delayed_methods { |
190 | return (qw/has with extends before after around override augment/); |
191 | } |
192 | |
193 | sub make_package_sub { |
194 | my ($self, $package) = @_; |
195 | my ($last) = (split('::', $package))[-1]; |
196 | return $last => sub { |
197 | $self->do_package_sub($package => @_); |
198 | }; |
199 | } |
200 | |
201 | sub do_package_sub { |
202 | my $self = shift; |
203 | my $package = shift; |
204 | return (@_ ? ($package => @_) : $package); |
205 | } |
206 | |
207 | sub make_sugar_sub { |
208 | my ($self, $name) = @_; |
209 | return $name => sub { |
210 | return ($name => @_); |
211 | }; |
212 | } |
213 | |
214 | sub make_code_sugar_sub { |
215 | my ($self, $name) = @_; |
216 | return $name => sub (;&@) { |
217 | return ($name => @_); |
218 | }; |
219 | } |
220 | |
221 | sub import { |
222 | my $self = shift; |
223 | my $pkg = caller; |
224 | my @args = @_; |
225 | &strict::import; |
226 | &warnings::import; |
227 | $self->do_import($pkg, \@args); |
228 | goto &{$self->next_import}; |
229 | } |
230 | |
231 | sub next_import { |
232 | return shift->next_import_package(@_)->can('import'); |
233 | } |
234 | |
235 | sub next_import_package { 'Moose' } |
236 | |
237 | 1; |
238 | |
239 | #---------#---------#---------#---------#---------#---------#---------#--------# |
240 | |
241 | =head1 NAME |
242 | |
243 | Reaction::Class |
244 | |
245 | =head1 DESCRIPTION |
246 | |
247 | =head1 SEE ALSO |
248 | |
249 | =over |
250 | |
251 | =item * L<Catalyst> |
252 | |
253 | =item * L<Reaction::Manual> |
254 | |
255 | =back |
256 | |
257 | =head1 Unstructured reminders |
258 | |
259 | (will properly format and stuff later. no time right now) |
260 | |
261 | C<use>ing C<Reaction::Class> will alias the current package name |
262 | see L<aliased>. |
263 | |
264 | package MyApp::Pretty::Picture |
265 | |
266 | # Picture expands to 'MyApp::Pretty::Picture' |
267 | class Picture, which { ... |
268 | |
269 | =head2 default_base |
270 | |
271 | =head2 set_or_lazy_build $attrname |
272 | |
273 | Will make your attributes lazy and required, if they are not set they |
274 | will default to the value returned by C<&build_$attrname> |
275 | |
276 | has created_d => (isa => 'DateTime', set_or_lazy_build('created_d') ); |
277 | sub build_created_d{ DateTime->now } |
278 | |
279 | =head2 set_or_lazy_fail $attrname |
280 | |
281 | Will make your attributes lazy and required, if they are not set |
282 | and their accessor is called an exception will be thrown |
283 | |
284 | =head2 trigger_adopt $attrname |
285 | |
286 | =head2 register_inc_entry |
287 | |
288 | =head2 reflect_attributes_from $from_class, @attrs |
289 | |
290 | Create attributes in the local class that mirror the specified C<@attrs> |
291 | in C<$from_class> |
292 | |
293 | =head2 class $name [, is $superclass ], which { |
294 | |
295 | Sugary class declaration, will create a a package C<$name> with an |
296 | optional base class of $superclass. The class declaration, should be placed inside |
297 | the brackets using C<implements> to declare a method and C<has> to declare an |
298 | attribute. |
299 | |
300 | =head2 does |
301 | |
302 | Alias to C<with> for the current package, see C<Moose::Role> |
303 | |
304 | =head2 implements $method_name [is | which | as] |
305 | |
306 | Only valid whithin a class block, allows you to declare a method for the class. |
307 | |
308 | implements 'current_date' => as { DateTime->today }; |
309 | |
310 | =head2 run |
311 | |
312 | =head1 AUTHORS |
313 | |
314 | =over |
315 | |
316 | =item * Matt S. Trout |
317 | |
318 | =item * K. J. Cheetham |
319 | |
320 | =item * Guillermo Roditi |
321 | |
322 | =item * Jess Robinson (Documentation) |
323 | |
324 | =item * Kaare Rasmussen (Documentation) |
325 | |
326 | =item * Andres N. Kievsky (Documentation) |
327 | |
328 | =back |
329 | |
330 | =head1 LICENSE |
331 | |
332 | This library is free software, you can redistribute it and/or modify |
333 | it under the same terms as Perl itself. |
334 | |
335 | =cut |