Reaction::Class - Reaction::Class documentation

    package MyApp::Pretty::Picture

    # Picture expands to 'MyApp::Pretty::Picture'
    class Picture, which { ...

    has created_d => (isa => 'DateTime', set_or_lazy_build('created_d') );
    sub build_created_d{ DateTime->now }

    implements 'current_date' => as { DateTime->today };

package Reaction::Class;

use Moose qw(confess);
use Sub::Exporter ();
use Sub::Name ();
use Reaction::Types::Core ':all';
use Reaction::Object;

sub exporter_for_package {
  my ($self, $package) = @_;
  my %exports_proto = $self->exports_for_package($package);
  no warnings 'uninitialized'; # XXX fix this
  my %exports = (
    map { my $cr = $exports_proto{$_}; ($_, sub { Sub::Name::subname "${self}::$_" => $cr; }) }
    keys %exports_proto
  );

  my $exporter = Sub::Exporter::build_exporter({
    exports => \%exports,
    groups  => {
        default => [':all']
    }
  });

  return $exporter;
}

sub do_import {
  my ($self, $pkg, $args) = @_;
  my $exporter = $self->exporter_for_package($pkg, $args);
  $exporter->($self, { into => $pkg }, @$args);
  if (my @default_base = $self->default_base) {
    no strict 'refs';
    @{"${pkg}::ISA"} = @default_base unless @{"${pkg}::ISA"};
  }
}

sub default_base { ('Reaction::Object'); }

sub exports_for_package {
  my ($self, $package) = @_;
  return (
    set_or_lazy_build => sub {
      my $name = shift;
      my $build = "build_${name}";
      return (required => 1, lazy => 1,
              default => sub { shift->$build(); });
    },
    set_or_lazy_fail => sub {
      my $name = shift;
      my $message = "${name} must be provided before calling reader";
      return (required => 1, lazy => 1,
              default => sub { confess($message); });
    },
    trigger_adopt => sub {
      my $type = shift;
      my @args = @_;
      my $adopt = "adopt_${type}";
      return (trigger => sub { shift->$adopt(@args); });
    },
    register_inc_entry => sub {
      my $inc = $package;
      $inc =~ s/::/\//g;
      $inc .= '.pm';
      $INC{$inc} = 1;
    },
    #this needs to go away soon. its never used. pollution.
    reflect_attributes_from => sub {
      my ($from_class, @attrs) = @_;

      #Should we use Class::Inspector to make sure class is loaded?
      #unless( Class::Inspector->loaded($from_class) ){
      #  eval "require $from_class" || die("Failed to load: $from_class");
      #}
      foreach my $attr_name (@attrs){
        my $from_attr = $from_class->meta->get_attribute($attr_name);
        confess("$from_attr does not exist in $from_class")
            unless $from_attr;
        #Not happy
        #$package->meta->add_attribute( $from_attr->name, %{$from_attr} );
        $package->meta->add_attribute( bless { %{$from_attr} } =>
                                       $package->meta->attribute_metaclass );
      }
    },
    class => sub {
      $self->do_class_sub($package, @_);
    },
    does => sub {
      $package->can('with')->(@_);
    },
    overrides => sub {
      $package->can('override')->(@_)
    },
    $self->make_package_sub($package),
    implements => sub { confess "implements only valid within class block" },
    $self->make_sugar_sub('is'),
    $self->make_code_sugar_sub('which'),
    $self->make_code_sugar_sub('as'),
    run => sub (;&@) { @_ },
  );
}

sub do_class_sub {
  my ($self, $package, $class, @args) = @_;
  my $error = "Invalid class declaration, should be: class Class (is Superclass)*, which { ... }";
  confess $error if (@args % 1);
  my @supers;
  while (@args > 2) {
    my $should_be_is = shift(@args);
    confess $error unless $should_be_is eq 'is';
    push(@supers, shift(@args));
  }
  confess $error unless $args[0] eq 'which' && ref($args[1]) eq 'CODE';
  my $setup = $args[1];

  #this eval is fucked, but I can't fix it
  unless ($class->can('meta')) {
    print STDERR "** MAKING CLASS $class useing Reaction::Class **\n";
    eval "package ${class}; use Reaction::Class;";
    if ($@) { confess "Couldn't make ${class} a Reaction class: $@"; }
  }
  if (@supers) {
    Class::MOP::load_class($_) for @supers;
    $class->meta->superclasses(@supers);
  }
  $self->setup_and_cleanup($package, $setup);

  #immutable code
  #print STDERR "$package \n";
  #print STDERR $package->meta->blessed, " \n";
  $package->meta->make_immutable;
  #    (inline_accessor    => 0, inline_destructor  => 0,inline_constructor => 0,);
}

sub setup_and_cleanup {
  my ($self, $package, $setup) = @_;
  my @methods;
  my @apply_after;
  my %save_delayed;
  {
    no strict 'refs';
    no warnings 'redefine';
    local *{"${package}::implements"} =
      Sub::Name::subname "${self}::implements" => sub {
        my $name = shift;
        shift if $_[0] eq 'as';
        push(@methods, [ $name, shift ]);
      };
    my $s = $setup;
    foreach my $meth ($self->delayed_methods) {
      $save_delayed{$meth} = $package->can($meth);
      my $s_copy = $s;
      $s = sub {
        local *{"${package}::${meth}"} =
          Sub::Name::subname "${self}::${meth}" => sub {
            push(@apply_after, [ $meth => @_ ]);
          };
        $s_copy->(@_);
      };
    }
    # XXX - need additional fuckery to handle multi-class-per-file
    $s->(); # populate up the crap
  }
  my %exports = $self->exports_for_package($package);
  {
    no strict 'refs';
    foreach my $nuke (keys %exports) {
      delete ${"${package}::"}{$nuke};
    }
  }
  my $unimport_class = $self->next_import_package;
  eval "package ${package}; no $unimport_class;";
  confess "$unimport_class unimport from ${package} failed: $@" if $@;
  foreach my $m (@methods) {
    $self->add_method_to_target($package, $m);
  }
  foreach my $a (@apply_after) {
    my $call = shift(@$a);
    $save_delayed{$call}->(@$a);
  }
}

sub add_method_to_target {
  my ($self, $target, $method) = @_;
  $target->meta->add_method(@$method);
}

sub delayed_methods {
  return (qw/has with extends before after around override augment/);
}

sub make_package_sub {
  my ($self, $package) = @_;
  my ($last) = (split('::', $package))[-1];
  return $last => sub {
    $self->do_package_sub($package => @_);
  };
}

sub do_package_sub {
  my $self = shift;
  my $package = shift;
  return (@_ ? ($package => @_) : $package);
}

sub make_sugar_sub {
  my ($self, $name) = @_;
  return $name => sub {
    return ($name => @_);
  };
}

sub make_code_sugar_sub {
  my ($self, $name) = @_;
  return $name => sub (;&@) {
    return ($name => @_);
  };
}

sub import {
  my $self = shift;
  my $pkg = caller;
  my @args = @_;
  strict->import;
  warnings->import;
  $self->do_import($pkg, \@args);
  goto &{$self->next_import} if $self->next_import;
}

sub next_import {
  return shift->next_import_package(@_)->can('import');
}

sub next_import_package { 'Moose' }

__PACKAGE__->meta->make_immutable;

1;

#---------#---------#---------#---------#---------#---------#---------#--------#