DDS bug..

[gitmo/MooseX-Antlers.git] / t / one.t

diff --git a/t/one.t b/t/one.t
index eddb112..cf15a34 100644 (file)
--- a/t/one.t
+++ b/t/one.t
@@ -1,54 +1,97 @@
 use strict;
 use warnings FATAL => 'all';
-use aliased 'MooseX::Antlers::EvalTracker';
-use aliased 'MooseX::Antlers::RefTracker';
-use aliased 'MooseX::Antlers::RefFilter';
-use B qw(perlstring);
+use MooseX::Antlers::Compiler;
 use lib 't/lib';
 use Test::More;
+use Test::Exception;
+use Class::Unload;
+use IO::All;
+use Data::Dumper::Concise;
+use Data::Dump::Streamer;
 
-my %attr_refs;
-my %attr_methods;
-
-{
-  require Moose;
-  my $orig = Moose->can('import');
-  no warnings 'redefine';
-  local *Moose::import = sub {
-    my $targ = caller;
-    Moose->$orig({ into => $targ });
-    my $has = $targ->can('has');
-    {
-      no strict 'refs';
-      *{"${targ}::has"} = sub {
-        $attr_refs{$_[0]} = RefTracker->trace_refs(
-          '$attributes{'.perlstring($_[0]).'}'
-          => \@_
-        );
-        my $et = EvalTracker->new->enable;
-        $has->(@_);
-        $attr_methods{$_[0]} = $et->recorded_coderefs;
-      };
-    }
-  };
-  require One;
+sub dump_meta {
+  my $meta = $_[0];
+  local $meta->{methods}{meta};
+  join '', Dump($meta);
 }
 
-ok(One->can('foo'), 'foo accessor installed');
+sub foo_called {
+  &cmp_ok(shift->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
+}
 
-use Data::Dump::Streamer;
+sub test_One {
+  my $class = shift;
 
-my $orig_foo_src = Dump(One->can('foo'));
+  ok($class->can('foo'), $class . ' foo accessor installed');
 
-# write test_class method that checks method including call
-# Class::Unload One
-# build compiled source
-# eval compiled source
-# run test_class after that as well as before unload
+  dies_ok { $class->new } $class . ' foo is required';
 
-use Data::Dumper::Concise;
+  foo_called($class, 0 => $class . ' trigger not called yet');
+
+  my $i = $class->new(foo => 1);
+
+  foo_called($class, 1 => $class . ' trigger called once (constructor)');
+
+  cmp_ok($i->foo, '==', 1, $class . ' read ok');
+
+  foo_called($class, 1 => $class . ' trigger not called for read');
+
+  $i->foo(2);
+
+  foo_called($class, 2 => $class . ' trigger called for setter');
+}
+
+test_class('One', \&test_One);
+test_class('Two', \&test_One);
+test_class('Three', \&test_One);
+
+sub test_class {
+    my ($class, $test) = @_;
+
+    my $compiler = MooseX::Antlers::Compiler->load_with_compiler($class);
+
+    # FIXME - foo
+    my %orig_src = map +($_ => join '', Dump($class->can($_))), qw(new DESTROY foo);
+
+    $class->meta->get_method_list; # fill cache
 
-#warn Dumper \%attr_refs;
-#warn Dumper \%attr_methods;
+    my $orig_meta = dump_meta $class->meta;
+
+    $test->($class);
+
+    my $compiled = $compiler->compiled_source;
+
+    #warn $compiled; done_testing; exit 0;
+
+    Class::Unload->unload($class);
+    Class::MOP::remove_metaclass_by_name($class);
+
+    io("/tmp/$class.pmc")->print($compiled);
+
+    require "/tmp/$class.pmc";
+
+    #eval "no warnings; $compiled";
+
+    #die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
+
+    my %compiled_src = map +($_ => join '', Dump($class->can($_))), qw(new DESTROY foo);
+
+    # FIXME - foo
+    foreach my $method (qw(new DESTROY foo)) {
+        is($compiled_src{$method}, $orig_src{$method}, "${method} restored ok");
+    }
+
+    my $compiled_meta = dump_meta $class->meta;
+
+    $test->($class);
+
+    #io('orig')->print($orig_meta);
+    #io('comp')->print($compiled_meta);
+
+    is($orig_meta, $compiled_meta, $class . ' metaclass restored ok');
+
+    Class::Unload->unload($class);
+    Class::MOP::remove_metaclass_by_name($class);
+}
 
 done_testing;