|
Packit |
37d9e7 |
#!/usr/bin/perl
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
use strict;
|
|
Packit |
37d9e7 |
BEGIN {
|
|
Packit |
37d9e7 |
$| = 1;
|
|
Packit |
37d9e7 |
$^W = 1;
|
|
Packit |
37d9e7 |
$ENV{PERL_PARAMS_UTIL_PP} ||= 1;
|
|
Packit |
37d9e7 |
}
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
sub _CODELIKE($);
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
use Test::More;
|
|
Packit |
37d9e7 |
use File::Spec::Functions ':ALL';
|
|
Packit |
37d9e7 |
use Scalar::Util qw(
|
|
Packit |
37d9e7 |
blessed
|
|
Packit |
37d9e7 |
reftype
|
|
Packit |
37d9e7 |
refaddr
|
|
Packit |
37d9e7 |
);
|
|
Packit |
37d9e7 |
use overload;
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
sub c_ok { is(
|
|
Packit |
37d9e7 |
refaddr(_CODELIKE($_[0])),
|
|
Packit |
37d9e7 |
refaddr($_[0]),
|
|
Packit |
37d9e7 |
"callable: $_[1]",
|
|
Packit |
37d9e7 |
) }
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
sub nc_ok {
|
|
Packit |
37d9e7 |
my $left = shift;
|
|
Packit |
37d9e7 |
$left = _CODELIKE($left);
|
|
Packit |
37d9e7 |
is( $left, undef, "not callable: $_[0]" );
|
|
Packit |
37d9e7 |
}
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
my @callables = (
|
|
Packit |
37d9e7 |
"callable itself" => \&_CODELIKE,
|
|
Packit |
37d9e7 |
"a boring plain code ref" => sub {},
|
|
Packit |
37d9e7 |
'an object with overloaded &{}' => C::O->new,
|
|
Packit |
37d9e7 |
'a object build from a coderef' => C::C->new,
|
|
Packit |
37d9e7 |
'an object with inherited overloaded &{}' => C::O::S->new,
|
|
Packit |
37d9e7 |
'a coderef blessed into CODE' => (bless sub {} => 'CODE'),
|
|
Packit |
37d9e7 |
);
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
my @uncallables = (
|
|
Packit |
37d9e7 |
"undef" => undef,
|
|
Packit |
37d9e7 |
"a string" => "a string",
|
|
Packit |
37d9e7 |
"a number" => 19780720,
|
|
Packit |
37d9e7 |
"a ref to a ref to code" => \(sub {}),
|
|
Packit |
37d9e7 |
"a boring plain hash ref" => {},
|
|
Packit |
37d9e7 |
'a class that builds from coderefs' => "C::C",
|
|
Packit |
37d9e7 |
'a class with overloaded &{}' => "C::O",
|
|
Packit |
37d9e7 |
'a class with inherited overloaded &{}' => "C::O::S",
|
|
Packit |
37d9e7 |
'a plain boring hash-based object' => UC->new,
|
|
Packit |
37d9e7 |
'a non-coderef blessed into CODE' => (bless {} => 'CODE'),
|
|
Packit |
37d9e7 |
);
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
my $tests = (@callables + @uncallables) / 2 + 2;
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
if ( $] > 5.006 ) {
|
|
Packit |
37d9e7 |
push @uncallables, 'a regular expression', qr/foo/;
|
|
Packit |
37d9e7 |
$tests += 1;
|
|
Packit |
37d9e7 |
}
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
plan tests => $tests;
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
# Import the function
|
|
Packit |
37d9e7 |
use_ok( 'Params::Util', '_CODELIKE' );
|
|
Packit |
37d9e7 |
ok( defined *_CODELIKE{CODE}, '_CODELIKE imported ok' );
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
while ( @callables ) {
|
|
Packit |
37d9e7 |
my $name = shift @callables;
|
|
Packit |
37d9e7 |
my $object = shift @callables;
|
|
Packit |
37d9e7 |
c_ok( $object, $name );
|
|
Packit |
37d9e7 |
}
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
while ( @uncallables ) {
|
|
Packit |
37d9e7 |
my $name = shift @uncallables;
|
|
Packit |
37d9e7 |
my $object = shift @uncallables;
|
|
Packit |
37d9e7 |
nc_ok( $object, $name );
|
|
Packit |
37d9e7 |
}
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
######################################################################
|
|
Packit |
37d9e7 |
# callable: is a blessed code ref
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
package C::C;
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
sub new {
|
|
Packit |
37d9e7 |
bless sub {} => shift;
|
|
Packit |
37d9e7 |
}
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
######################################################################
|
|
Packit |
37d9e7 |
# callable: overloads &{}
|
|
Packit |
37d9e7 |
# but only objects are callable, not class
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
package C::O;
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
sub new {
|
|
Packit |
37d9e7 |
bless {} => shift;
|
|
Packit |
37d9e7 |
}
|
|
Packit |
37d9e7 |
use overload '&{}' => sub { sub {} };
|
|
Packit |
37d9e7 |
use overload 'bool' => sub () { 1 };
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
######################################################################
|
|
Packit |
37d9e7 |
# callable: subclasses C::O
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
package C::O::S;
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
use vars qw{@ISA};
|
|
Packit |
37d9e7 |
BEGIN {
|
|
Packit |
37d9e7 |
@ISA = 'C::O';
|
|
Packit |
37d9e7 |
}
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
######################################################################
|
|
Packit |
37d9e7 |
# uncallable: some boring object with no codey magic
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
package UC;
|
|
Packit |
37d9e7 |
|
|
Packit |
37d9e7 |
sub new {
|
|
Packit |
37d9e7 |
bless {} => shift;
|
|
Packit |
37d9e7 |
}
|