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;
   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;
 132 #      (inline_accessor    => 0, inline_destructor  => 0,inline_constructor => 0,);
 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