view release on metacpan or  search on metacpan

lib/match/smart.pm  view on Meta::CPAN

		return match( [ sort map "$_", keys %$a ], [ sort map "$_", keys %$b ] )
			if ref($a) eq q(HASH);
		
		return any { exists $b->{$_} } @$a  if ref( $a ) eq q(ARRAY);
		return any { $_ =~ $a } keys %$b    if ref( $a ) eq q(Regexp);
		return !!0                          if !defined( $a );
		return exists $b->{$a};
	}
	
	if ( ref($b) eq q(CODE) ) {
		return all { !!$b->($_) } @$a       if ref( $a ) eq q(ARRAY);
		return all { !!$b->($_) } keys %$a  if ref( $a ) eq q(HASH);
		return $b->( $a );
	}
	
	if ( ref($b) eq q(Regexp) ) {
		return any { $_ =~ $b } @$a       if ref( $a ) eq q(ARRAY);
		return any { $_ =~ $b } keys %$a  if ref( $a ) eq q(HASH);
		return $a =~ $b;
	}
	
	return !!$a->$method( $b, 0 )           if blessed( $a ) && ( $method = _overloaded_smartmatch( $a ) );
	return !defined( $b )                   if !defined( $a );
	return $a == $b                         if _is_number( $b );
	return $a == $b                         if _is_number( $a ) && looks_like_number( $b );
	
	return $a eq $b;
}

sub _is_number {
	my $value = shift;
	return if ref $value;
	my $flags = B::svref_2object( \$value )->FLAGS;
	$flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK );
}

sub _generate_M {
	require Sub::Infix;
	&Sub::Infix::infix( \&match );
}

unless ( eval 'require re; 1' and exists &re::is_regexp ) {
	require B;
	*re::is_regexp = sub {
		eval { B::svref_2object( $_[0] )->MAGIC->TYPE eq 'r' };
	};
}

sub _overloaded_smartmatch {
	my ( $obj ) = @_;
	return if re::is_regexp( $obj );
	
	if ( $obj->isa( 'Type::Tiny' ) ) {
		return $obj->can( 'check' );
	}
	
	if ( my $match = $obj->can( 'MATCH' ) ) {
		return $match;
	}
	
	if ( $] lt '5.010' ) { require MRO::Compat; }
	else                 { require mro;         }
	
	my @mro = @{ mro::get_linear_isa( ref $obj ) };
	for my $class ( @mro ) {
		my $name = "$class\::(~~";
		my $overload = do {
			no strict 'refs';
			exists( &$name ) ? \&$name : undef;
		};
		return $overload if defined $overload;
	}
	
	return;
}

1;

__END__

=pod

=encoding utf-8

=for stopwords smartmatch recurses

=head1 NAME

match::smart - clone of smartmatch operator

=head1 SYNOPSIS

   use v5.10;
   use match::smart;
   
   if ($this |M| $that)
   {
      say "$this matches $that";
   }

=head1 DESCRIPTION

match::smart provides a match operator C<< |M| >> that acts like more or
less identically to the (as of Perl 5.18) deprecated smart match operator.

If you don't like the crazy L<Sub::Infix> operator, you can alternatively
export a more normal function:

   use v5.10;
   use match::smart qw(match);
   
   if (match($this, $that))
   {
      say "$this matches $that";
   }

=head2 Differences with ~~

There were major changes to smart match between 5.10.0 and 5.10.1. This
module attempts to emulate the behaviour of the operator in more recent
versions of Perl. In particular, 5.18.0 (minus the warnings). Divergences