1#!/usr/bin/perl -w 2 3use strict; 4 5use Params::Validate qw(validate); 6use Test::More tests => 13; 7 8{ 9 my @p = ( foo => 'ClassCan' ); 10 11 eval 12 { 13 validate( @p, 14 { foo => { can => 'cancan' } }, 15 ); 16 }; 17 18 is( $@, q{} ); 19 20 eval 21 { 22 validate( @p, 23 { foo => { can => 'thingy' } }, 24 ); 25 }; 26 27 like( $@, qr/does not have the method: 'thingy'/ ); 28} 29 30{ 31 my @p = ( foo => undef ); 32 eval 33 { 34 validate( @p, 35 { foo => { can => 'baz' } }, 36 ); 37 }; 38 39 like( $@, qr/does not have the method: 'baz'/ ); 40} 41 42{ 43 my $object = bless {}, 'ClassCan'; 44 my @p = ( foo => $object ); 45 46 eval 47 { 48 validate( @p, 49 { foo => { can => 'cancan' } }, 50 ); 51 }; 52 53 is( $@, q{} ); 54 55 eval 56 { 57 validate( @p, 58 { foo => { can => 'thingy' } }, 59 ); 60 }; 61 62 like( $@, qr/does not have the method: 'thingy'/ ); 63} 64 65{ 66 my @p = ( foo => 'SubClass' ); 67 68 eval 69 { 70 validate( @p, 71 { foo => { can => 'cancan' } }, 72 ); 73 }; 74 75 is( $@, q{}, 'SubClass->can(cancan)' ); 76 77 eval 78 { 79 validate( @p, 80 { foo => { can => 'thingy' } }, 81 ); 82 }; 83 84 like( $@, qr/does not have the method: 'thingy'/ ); 85} 86 87{ 88 my $object = bless {}, 'SubClass'; 89 my @p = ( foo => $object ); 90 91 eval 92 { 93 validate( @p, 94 { foo => { can => 'cancan' } }, 95 ); 96 }; 97 98 is( $@, q{}, 'SubClass object->can(cancan)' ); 99 100 eval 101 { 102 validate( @p, 103 { foo => { can => 'thingy' } }, 104 ); 105 }; 106 107 like( $@, qr/does not have the method: 'thingy'/ ); 108} 109 110{ 111 my @p = ( foo => {} ); 112 eval 113 { 114 validate( @p, 115 { foo => { can => 'thingy' } }, 116 ); 117 }; 118 like( $@, qr/does not have the method: 'thingy'/, 'unblessed ref ->can' ); 119 120 @p = ( foo => 27 ); 121 eval 122 { 123 validate( @p, 124 { foo => { can => 'thingy' } }, 125 ); 126 }; 127 like( $@, qr/does not have the method: 'thingy'/, 'number can' ); 128 129 @p = ( foo => 'A String' ); 130 eval 131 { 132 validate( @p, 133 { foo => { can => 'thingy' } }, 134 ); 135 }; 136 like( $@, qr/does not have the method: 'thingy'/, 'string can' ); 137 138 @p = ( foo => undef ); 139 eval 140 { 141 validate( @p, 142 { foo => { can => 'thingy' } }, 143 ); 144 }; 145 like( $@, qr/does not have the method: 'thingy'/, 'undef can' ); 146} 147 148 149package ClassCan; 150 151sub can 152{ 153 return 1 if $_[1] eq 'cancan'; 154 return 0; 155} 156 157sub thingy { 1 } 158 159package SubClass; 160 161use base 'ClassCan'; 162 163 164