does.pl

#!/usr/bin/env perl

# Perl 5 needs a does built-in.
# http://perldoc.perl.org/5.14.2/perltodo.html#A-does()-built-in
#
# In an ideal world the syntax would be `$foo does $bar` but Perl doesn't
# seem able to add infix operators via a module, so `$foo ~~does $bar` is
# needed. (Also in an ideal world it would have the same precedence as `eq`.
#

use 5.014;

package does 0.001
{
	BEGIN { $INC{'does.pm'} = __FILE__ };
	
	use IO::Detect qw( is_filehandle );
	use overload qw();
	use Scalar::Util qw( blessed reftype );	
	use Sub::Exporter -setup => {
		exports => [qw( does overloads )],
		groups  => {
			default => [qw( does )],
		},
	};
	no warnings;
	
	my %ROLES = (
		SCALAR   => sub { reftype($_) eq 'SCALAR'  or overloads($_, q[${}]) },
		ARRAY    => sub { reftype($_) eq 'ARRAY'   or overloads($_, q[@{}]) },
		HASH     => sub { reftype($_) eq 'HASH'    or overloads($_, q[%{}]) },
		CODE     => sub { reftype($_) eq 'CODE'    or overloads($_, q[&{}]) },
		REF      => sub { reftype($_) eq 'REF' },
		GLOB     => sub { reftype($_) eq 'GLOB'    or overloads($_, q[*{}]) },
		LVALUE   => sub { ref($_) eq 'LVALUE' },
		FORMAT   => sub { reftype($_) eq 'FORMAT' },
		IO       => \&is_filehandle,
		VSTRING  => sub { reftype($_) eq 'VSTRING' or reftype($_) eq 'VSTRING' },
		Regexp   => sub { reftype($_) eq 'Regexp'  or overloads($_, q[qr]) },
		q[${}]   => 'SCALAR',
		q[@{}]   => 'ARRAY',
		q[%{}]   => 'HASH',
		q[&{}]   => 'CODE',
		q[*{}]   => 'GLOB',
		q[bool]  => sub { !blessed($_) or !overload::Overloaded($_) or overloads($_, q[bool]) },
		q[""]    => sub { !ref($_)     or !overload::Overloaded($_) or overloads($_, q[""]) },
		q[0+]    => sub { !ref($_)     or !overload::Overloaded($_) or overloads($_, q[0+]) },
		q[qr]    => sub { reftype($_) eq 'Regexp'  or overloads($_, q[qr]) },
		q[<>]    => sub { overloads($_, q[<>])     or is_filehandle($_) },
		q[~~]    => sub { overloads($_, q[~~])     or not blessed($_) },
	);
	
	while (my ($k, $v) = each %ROLES)
		{ $ROLES{$k} = $ROLES{$v} unless ref $v }
	
	sub overloads ($;$)
	{
		my ($thing, $role) = @_;
		
		# curry (kinda)
		return sub { overloads(shift, $thing) } if @_ < 2;
		
		goto \&overload::Method;
	}
	
	sub does ($;$)
	{
		my ($thing, $role) = @_;
		
		# curry (kinda)
		return sub { does(shift, $thing) } if @_ < 2;
		
		if (my $test = $ROLES{$role})
		{
			local $_ = $thing;
			my $does = $test->($thing);
			return 1 if $does;
		}
		
		if (blessed $thing)
		{
			return $thing->DOES($role);
		}
		
		return;
	}
}

package main
{
	use does;

	my $var = [];

	# Prefix notation
	if (does $var, 'ARRAY')
	{
		say '$var does ARRAY'
	}

	# Pseudo-infix notation
	if ($var ~~does 'ARRAY')
	{
		say '$var does ARRAY'
	}
}