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