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