this, sort of, works

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

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 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_et;
my $im_et;

{
  require Moose;
  my $orig_import = Moose->can('import');
  no warnings 'redefine';
  local *Moose::import = sub {
    my $targ = caller;
    Moose->$orig_import({ into => $targ });
    my $has = $targ->can('has');
    {
      no strict 'refs';
      *{"${targ}::has"} = sub {
        $attr_refs{$_[0]} = [
          map RefTracker->trace_refs( $_ => \@_ ),
            '(\@_)', '$has_args{'.perlstring($_[0]).'}'
        ];
        my $et = EvalTracker->new->enable;
        $has->(@_);
        $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;
}

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 $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
# build compiled source
# eval compiled source
# run test_class after that as well as before unload

#warn Dumper \%attr_refs;
#warn Dumper \%attr_et;
#warn Dumper $im_et;

done_testing;