this, sort of, works

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

diff --git a/t/one.t b/t/one.t
index eddb112..aef210f 100644 (file)
--- a/t/one.t
+++ b/t/one.t
@@ -6,39 +6,140 @@ use aliased 'MooseX::Antlers::RefFilter';
 use B qw(perlstring);
 use lib 't/lib';
 use Test::More;
+use Test::Exception;
+use Class::Unload;
+use String::TT qw(tt strip);
+use IO::All qw(io);
 
 my %attr_refs;
-my %attr_methods;
+my %attr_et;
+my $im_et;
 
 {
   require Moose;
-  my $orig = Moose->can('import');
+  my $orig_import = Moose->can('import');
   no warnings 'redefine';
   local *Moose::import = sub {
     my $targ = caller;
-    Moose->$orig({ into => $targ });
+    Moose->$orig_import({ into => $targ });
     my $has = $targ->can('has');
     {
       no strict 'refs';
       *{"${targ}::has"} = sub {
-        $attr_refs{$_[0]} = RefTracker->trace_refs(
-          '$attributes{'.perlstring($_[0]).'}'
-          => \@_
-        );
+        $attr_refs{$_[0]} = [
+          map RefTracker->trace_refs( $_ => \@_ ),
+            '(\@_)', '$has_args{'.perlstring($_[0]).'}'
+        ];
         my $et = EvalTracker->new->enable;
         $has->(@_);
-        $attr_methods{$_[0]} = $et->recorded_coderefs;
+        $attr_et{$_[0]} = $et->disable;
+        return;
       };
     }
   };
+  my $orig_immutable = Moose::Meta::Class->can('make_immutable');
+  local *Moose::Meta::Class::make_immutable = sub {
+    my $et = EvalTracker->new->enable;
+    $orig_immutable->(@_);
+    $im_et = $et->disable;
+    return;
+  };
   require One;
 }
 
-ok(One->can('foo'), 'foo accessor installed');
+sub foo_called {
+  &cmp_ok(One->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
+}
+
+sub test_One {
+
+  ok(One->can('foo'), 'foo accessor installed');
+
+  dies_ok { One->new } 'foo is required';
+
+  foo_called(0 => 'trigger not called yet');
+
+  my $one = One->new(foo => 1);
+
+  foo_called(1 => 'trigger called once (constructor)');
+
+  cmp_ok($one->foo, '==', 1, 'read ok');
+
+  foo_called(1 => 'trigger not called for read');
+
+  $one->foo(2);
+
+  foo_called(2 => 'trigger called for setter');
+}
+
+my %orig_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY one);
+
+my $orig_foo_meta = Dump(One->meta);
+
+test_One();
 
 use Data::Dump::Streamer;
 
-my $orig_foo_src = Dump(One->can('foo'));
+my $one_source_code = io($INC{'One.pm'})->all;
+
+#warn $attr_et{'foo'}->serialized_construction($attr_refs{'foo'});
+
+#my @has = (
+
+my $foo_build = $attr_et{'foo'}->serialized_construction($attr_refs{'foo'}[0]);
+
+my $im_build = $im_et->serialized_construction($attr_refs{'foo'}[1]);
+
+my $preamble = strip tt q{
+  my %replay_has;
+  my %has_args;
+  BEGIN {
+    %replay_has = (
+      foo => sub {
+        [% foo_build %]
+      }
+    );
+  }
+  sub MooseX::Antlers::ImmutableHackFor::Foo::make_immutable {
+[% im_build %]
+  }
+  use MooseX::Antlers::StealImport
+    Moose => {
+      -do => sub {
+        strict->import;
+        warnings->import;
+      },
+      has => sub {
+        $has_args{$_[0]} = \@_;
+        ($replay_has{$_[0]}||die "Can't find replay for $_[0]")
+          ->(@_);
+      },
+      meta => sub { 'MooseX::Antlers::ImmutableHackFor::Foo' }
+    };
+};
+
+my $postamble = strip q{
+  no MooseX::Antlers::StealImport qw(Moose);
+};
+
+my $compiled = join("\n", $preamble, $one_source_code, $postamble);
+
+#warn $compiled; done_testing; exit 0;
+
+Class::Unload->unload('One');
+Class::MOP::remove_metaclass_by_name('One');
+
+eval $compiled; die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
+
+use Data::Dumper::Concise;
+
+my %compiled_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY one);
+
+#foreach my $method (qw(new DESTROY one)) {
+#  is($compiled_src{$method}, $orig_src{$method}, "${method} restored ok");
+#}
+
+test_One;
 
 # write test_class method that checks method including call
 # Class::Unload One
@@ -46,9 +147,8 @@ my $orig_foo_src = Dump(One->can('foo'));
 # eval compiled source
 # run test_class after that as well as before unload
 
-use Data::Dumper::Concise;
-
 #warn Dumper \%attr_refs;
-#warn Dumper \%attr_methods;
+#warn Dumper \%attr_et;
+#warn Dumper $im_et;
 
 done_testing;