Validatorを通せる君

Test::MockObject::AnonClass.pm

package Test::MockObject::AnonClass;

use Class::Load qw/load_class/;
use Exporter::Lite;
use String::CamelCase qw/decamelize/;
use List::AllUtils qw/none uniq/;
our @EXPORT_OK = qw/create_anon_object/;

=encoding utf8

=head1 NAME

Test::MockObject::AnonClass;

=head1 SYNOPSIS

    package Hoge {
        sub hoge {}
        sub fuga {}
    }

    use Test::MockObject::AnonClass qw/create_anon_object/;

    my $hoge = create_anon_object +{
        parent => 'Hoge',                       # 必須
        methods => +{                           # default: +{}
            hoge => sub { warn 'overrided' },
            bar  => sub { warn 'overrided' },
        },
        guard => 1,                             # default: 1
        guard_sub => sub { warn 'guarded' },    # default: die with message
        properties => +{                        # default: +{}
            xxx => 30,
        }
    };                                          # warning! bar is not defined for parent class

    $hoge->hoge;                                #-> print overrided
    $hoge->fuga;                                #-> print guarded
    $hoge->bar;                                 #-> print overrided

    $hoge->{xxx};                               #-> return 30

    use Data::Validator;
    Data::Validator->new(hoge => 'Hoge')->validate({ hoge => $hoge });    # ok

=head1 DESCRIPTION

匿名クラスを作り、それに指定した親クラスを継承させることでValidatorを通るMockObjectを生成します。
親クラスのメソッドが呼ばれないように、デフォルトでガードしますが、明示的に`guard => 0`を指定すれば外すことができます。

基本的には型チェックが入るメソッドのテストに使用することを想定しています。

=head1 FUNCTIONS


=head2 create_anon_object

ハッシュリファレンスを受け取り、デフォルト値などを設定してオブジェクトを生成します。

=head3 ARGS

=over

=item parent (required)

匿名クラスの親クラスを指定します。
ここで指定したクラスのバリデーションを通すことができます。

=item guard (optional default: 1)

真の場合、親クラスのメソッドが呼ばれないようにguard_subで隠蔽します。
何も指定しなければ真になります。

=item guard_sub (optional default: die function)

guardが真の場合、このコードリファレンスで親クラスのメソッドを隠蔽します。

=item methods (optional default: +{})

キーの名前のメソッドを、値のコードリファレンスで作成します。
値がコードリファレンスでない場合、その値を返すコードリファレンスがメソッドに設定されます。
何も指定しなければ空のハッシュになります。

=item properties (optional default: +{})

匿名クラスをblessするオブジェクトを指定できます。
何も指定しなければ空のハッシュになります。

=back

=cut

sub create_anon_object($) {
    my $hash = shift;
    my $parent     = $hash->{parent}     // die 'required parameter: parent';
    my $guard      = $hash->{guard}      // 1;
    my $guard_sub  = $hash->{guard_sub};        # XXX: guard_subはcaller情報出したいので_guard_all_methodsで指定
    my $methods    = $hash->{methods}    // +{};
    my $properties = $hash->{properties} // +{};

    __PACKAGE__->new($parent, $guard, $guard_sub, $methods, $properties);
}

sub new {
    my ($class, $disguice_class, $guard, $guard_sub, $methods, $properties) = @_;
    my $anon_class = $class->_anon_class_name($methods);

    my $obj = bless $properties => $anon_class;
    eval sprintf(q{push @%s::ISA, '%s'}, $anon_class, $disguice_class);
    load_class $disguice_class;

    $class->_warn_no_define_methods($disguice_class, [keys %$methods]);
    $class->_guard_all_methods($anon_class, $disguice_class, $guard_sub) if $guard;
    $class->_transplant_methods($anon_class, $disguice_class, $methods);
    $class->_register_destroy_class($anon_class);

    return $obj;
}

sub _anon_class_name {
    my ($class, $hash) = @_;
    my $new_hash = +{ %$hash };
    my $anon_class = "Test::MockObject::AnonClass::Instance::$new_hash";
    $anon_class =~ s/(HASH|\)|\()//g;
    return $anon_class;
}

sub _warn_no_define_methods {
    my ($class, $disguice_class, $method_names) = @_;
    my @disguice_class_methods = $class->_get_all_methods($disguice_class);

    # 親クラスに存在しないメソッドをモックしようとした場合warnを出す
    for my $method_name (@$method_names) {
        warn "${disguice_class}::${method_name} is not defined!" if none { $method_name eq $_ } @disguice_class_methods;
    }
}

sub _guard_all_methods {
    my ($class, $anon_class, $disguice_class, $guard_sub) = @_;

    no strict 'refs';
    my @methods = $class->_get_all_methods($disguice_class);

    for my $method (@methods) {
        *{ "${anon_class}::$method" } = $guard_sub // sub {
            my ($pkg, $file, $line) = caller 0;
            die "[$method] guarded! if you wanted to call parent methods, specify `guard => 0` on anon_object at $file:$line\n";
        };
    }

}

# XXX: AUTOLOAD対策とかできてない
sub _get_all_methods {
    my ($class, $disguice_class) = @_;
    my %symbol = eval "%${disguice_class}::";
    my @methods = grep { $disguice_class->can($_) } keys %symbol;

    return @methods;
}

sub _transplant_methods {
    my ($class, $anon_class, $disguice_class, $methods) = @_;

    no strict 'refs';
    no warnings 'redefine';
    while (my ($method_name, $code_ref_or_value) = each %$methods) {
        *{ "${anon_class}::$method_name" } = ref $code_ref_or_value eq 'CODE'
            ? $code_ref_or_value
            : sub { $code_ref_or_value };
    }
}

sub _register_destroy_class {
    my ($class, $anon_class) = @_;
    no strict 'refs';
    *{"${anon_class}::DESTROY"} = sub {
        %{"${anon_class}::"} = ();
    };
};

1;