view release on metacpan or  search on metacpan

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

	eval {
		require match::simple::XS;
		match::simple::XS->VERSION( 0.002 );  # minimum
		
		# Unless we're a development version...
		# Avoid using an unstable version of ::XS
		unless (match::simple->VERSION =~ /_/) {
			die if match::simple::XS->VERSION =~ /_/;
		}
		
		$xs = match::simple::XS->can('match');
	};
}

eval($xs ? <<'XS' : <<'PP');

sub IMPLEMENTATION () { "XS" }

*match = *match::simple::XS::match;

XS

sub IMPLEMENTATION () { "PP" }

sub match {
	no warnings qw( uninitialized numeric );
	
	my ( $a, $b ) = @_;
	my $method;
	
	return !defined $a                      if !defined($b);
	return $a eq $b                         if !ref($b);
	return $a =~ $b                         if ref($b) eq q(Regexp);
	return do { local $_ = $a; !!$b->($a) } if ref($b) eq q(CODE);
	return any { match( $a, $_ ) } @$b      if ref($b) eq q(ARRAY);
	return !!$b->$method( $a, 1 )           if blessed($b) && ( $method = _overloaded_smartmatch( $b ) );
	
	require Carp;
	Carp::croak( "match::simple cannot match anything against: $b" );
}

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 $overload;
	}
	
	return;
}

PP

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

1;

__END__

=pod

=encoding utf-8

=for stopwords smartmatch recurses

=head1 NAME

match::simple - simplified clone of smartmatch operator

=head1 SYNOPSIS

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

=head1 DESCRIPTION

match::simple provides a simple match operator C<< |M| >> that acts like
a sane subset of the (as of Perl 5.18) deprecated smart match operator.
Unlike smart match, the behaviour of the match is determined entirely by
the operand on the right hand side.

=over

=item *

If the right hand side is C<undef>, then there is only a match if the left
hand side is also C<undef>.

=item *