1 package Reaction::Class;
6 use Reaction::Types::Core ':all';
9 sub exporter_for_package {
10 my ($self, $package) = @_;
11 my %exports_proto = $self->exports_for_package($package);
12 no warnings 'uninitialized'; # XXX fix this
14 map { my $cr = $exports_proto{$_}; ($_, sub { Sub::Name::subname "${self}::$_" => $cr; }) }
18 my $exporter = Sub::Exporter::build_exporter({
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) {
34 @{"${pkg}::ISA"} = @default_base unless @{"${pkg}::ISA"};
38 sub default_base { ('Reaction::Object'); }
40 sub exports_for_package {
41 my ($self, $package) = @_;
43 set_or_lazy_build => sub {
45 my $build = "build_${name}";
46 return (required => 1, lazy => 1,
47 default => sub { shift->$build(); });
49 set_or_lazy_fail => sub {
51 my $message = "${name} must be provided before calling reader";
52 return (required => 1, lazy => 1,
53 default => sub { confess($message); });
55 trigger_adopt => sub {
58 my $adopt = "adopt_${type}";
59 return (trigger => sub { shift->$adopt(@args); });
61 register_inc_entry => sub {
67 #this needs to go away soon. its never used. pollution.
68 reflect_attributes_from => sub {
69 my ($from_class, @attrs) = @_;
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");
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")
80 #$package->meta->add_attribute( $from_attr->name, %{$from_attr} );
81 $package->meta->add_attribute( bless { %{$from_attr} } =>
82 $package->meta->attribute_metaclass );
86 $self->do_class_sub($package, @_);
89 $package->can('with')->(@_);
92 $package->can('override')->(@_)
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 (;&@) { @_ },
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);
109 my $should_be_is = shift(@args);
110 confess $error unless $should_be_is eq 'is';
111 push(@supers, shift(@args));
113 confess $error unless $args[0] eq 'which' && ref($args[1]) eq 'CODE';
114 my $setup = $args[1];
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: $@"; }
123 Class::MOP::load_class($_) for @supers;
124 $class->meta->superclasses(@supers);
126 $self->setup_and_cleanup($package, $setup);
129 #print STDERR "$package \n";
130 #print STDERR $package->meta->blessed, " \n";
131 $package->meta->make_immutable;
132 # (inline_accessor => 0, inline_destructor => 0,inline_constructor => 0,);
135 sub setup_and_cleanup {
136 my ($self, $package, $setup) = @_;
142 no warnings 'redefine';
143 local *{"${package}::implements"} =
144 Sub::Name::subname "${self}::implements" => sub {
146 shift if $_[0] eq 'as';
147 push(@methods, [ $name, shift ]);
150 foreach my $meth ($self->delayed_methods) {
151 $save_delayed{$meth} = $package->can($meth);
154 local *{"${package}::${meth}"} =
155 Sub::Name::subname "${self}::${meth}" => sub {
156 push(@apply_after, [ $meth => @_ ]);
161 # XXX - need additional fuckery to handle multi-class-per-file
162 $s->(); # populate up the crap
164 my %exports = $self->exports_for_package($package);
167 foreach my $nuke (keys %exports) {
168 delete ${"${package}::"}{$nuke};
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) {
175 $self->add_method_to_target($package, $m);
177 foreach my $a (@apply_after) {
178 my $call = shift(@$a);
179 $save_delayed{$call}->(@$a);
183 sub add_method_to_target {
184 my ($self, $target, $method) = @_;
185 $target->meta->add_method(@$method);
188 sub delayed_methods {
189 return (qw/has with extends before after around override augment/);
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 => @_);
203 return (@_ ? ($package => @_) : $package);
207 my ($self, $name) = @_;
208 return $name => sub {
209 return ($name => @_);
213 sub make_code_sugar_sub {
214 my ($self, $name) = @_;
215 return $name => sub (;&@) {
216 return ($name => @_);
226 $self->do_import($pkg, \@args);
227 goto &{$self->next_import};
231 return shift->next_import_package(@_)->can('import');
234 sub next_import_package { 'Moose' }
238 #---------#---------#---------#---------#---------#---------#---------#--------#
252 =item * L<Reaction::Manual>
256 =head1 Unstructured reminders
258 (will properly format and stuff later. no time right now)
260 C<use>ing C<Reaction::Class> will alias the current package name
263 package MyApp::Pretty::Picture
265 # Picture expands to 'MyApp::Pretty::Picture'
266 class Picture, which { ...
270 =head2 set_or_lazy_build $attrname
272 Will make your attributes lazy and required, if they are not set they
273 will default to the value returned by C<&build_$attrname>
275 has created_d => (isa => 'DateTime', set_or_lazy_build('created_d') );
276 sub build_created_d{ DateTime->now }
278 =head2 set_or_lazy_fail $attrname
280 Will make your attributes lazy and required, if they are not set
281 and their accessor is called an exception will be thrown
283 =head2 trigger_adopt $attrname
285 =head2 register_inc_entry
287 =head2 reflect_attributes_from $from_class, @attrs
289 Create attributes in the local class that mirror the specified C<@attrs>
292 =head2 class $name [, is $superclass ], which {
294 Sugary class declaration, will create a a package C<$name> with an
295 optional base class of $superclass. The class declaration, should be placed inside
296 the brackets using C<implements> to declare a method and C<has> to declare an
301 Alias to C<with> for the current package, see C<Moose::Role>
303 =head2 implements $method_name [is | which | as]
305 Only valid whithin a class block, allows you to declare a method for the class.
307 implements 'current_date' => as { DateTime->today };
315 =item * Matt S. Trout
317 =item * K. J. Cheetham
319 =item * Guillermo Roditi
321 =item * Jess Robinson (Documentation)
323 =item * Kaare Rasmussen (Documentation)
325 =item * Andres N. Kievsky (Documentation)
327 =item * Robert Sedlacek (Documentation)
337 L<Ionzero|http://www.ionzero.com/> sponsored the writing of the
338 L<Reaction::Manual::Tutorial>, L<Reaction::Manual::Overview> and
339 L<Reaction::Manual::Widgets> documentations as well as improvements
340 to L<Reaction::Manual::Intro> and many API documentation improvements
341 throughout the project.
347 This library is free software, you can redistribute it and/or modify
348 it under the same terms as Perl itself.