lib/Reaction/Class.pm

   1 package Reaction::Class;
   2
   3 use Moose qw(confess);
   4 use Sub::Exporter ();
   5 use Sub::Name ();
   6 use Reaction::Types::Core ':all';
   7 use Reaction::Object;
   8
   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
  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;
 133   #    (inline_accessor    => 0, inline_destructor  => 0,inline_constructor => 0,);
 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     my $s = $setup;
 151     foreach my $meth ($self->delayed_methods) {
 152       $save_delayed{$meth} = $package->can($meth);
 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       };
 161     }
 162     # XXX - need additional fuckery to handle multi-class-per-file
 163     $s->(); # populate up the crap
 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) {
 176     $self->add_method_to_target($package, $m);
 177   }
 178   foreach my $a (@apply_after) {
 179     my $call = shift(@$a);
 180     $save_delayed{$call}->(@$a);
 181   }
 182 }
 183
 184 sub add_method_to_target {
 185   my ($self, $target, $method) = @_;
 186   $target->meta->add_method(@$method);
 187 }
 188
 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