File Coverage

blib/lib/Switch/Perlish/Smatch.pm

Criterion	Covered	Total	%
statement	66	67	98.5
branch	23	30	76.6
condition	23	29	79.3
subroutine	18	18	100.0
pod	6	6	100.0
total	136	150	90.6

package Switch::Perlish::Smatch;

$VERSION = '1.0.1';

require Exporter;
@EXPORT_OK = qw/ smatch value_cmp /;
@ISA       = 'Exporter';

use strict;
use warnings;

use vars '%REGISTER';
use warnings::register;

use Carp 'croak';
use Scalar::Util 'blessed';

## XXX: Convert %REGISTRY to a class heirarchy?
## XXX: Make tests more consistent?
## XXX: Provide an easy way to default to existing comparators?

## XXX: Should this be done 'smartly?'
require Switch::Perlish::Smatch::Value;
require Switch::Perlish::Smatch::Undef;
require Switch::Perlish::Smatch::Scalar;
require Switch::Perlish::Smatch::Array;
require Switch::Perlish::Smatch::Hash;
require Switch::Perlish::Smatch::Code;
require Switch::Perlish::Smatch::Object;
require Switch::Perlish::Smatch::Regexp;

## Thanks to merlyn for this snippet.
sub _is_num {
  no warnings;
  return ($_[0] & ~ $_[0]) eq "0";
}

sub value_cmp {
  my($a,$b) = @_;
  ## Try to compare 2 strings then 2 numbers then do a regexp guesstimate.
  !_is_num($a) and !_is_num($b) and return $a eq $b;
   _is_num($a) and  _is_num($b) and return $a == $b;
  no warnings;
  return $a =~ /\A$b\z/;
}

sub match {
  my $self   = @_ == 3 ? shift : __PACKAGE__;
  my($t, $m) = @_;
  my($t_type, $m_type) = map _get_type($_), $t, $m;

  ## Default to OBJECT if we don't have a registered class comparator.
  $t_type = 'OBJECT'
    if blessed($t) and !$self->is_registered($t_type);
  $m_type = 'OBJECT'
    if blessed($m) and !$self->is_registered($t_type, $m_type);
  ## Treat REF the same as SCALAR, i.e KISS.
  $_ eq 'REF' and $_ = 'SCALAR'
    for $t_type, $m_type;

  return $self->dispatch( $t_type, $m_type, $t, $m );
}

## for exporting
*smatch = \&match;

## Make this public?
sub _get_type {
  my $foo  = shift;
  ## XXX: Is this the best way to check?
  ## Get the class name, or the reference type, or we're a value/undef.
  return blessed($foo) || ref($foo) || ( defined($foo) ? 'VALUE' : 'UNDEF' );
}

sub dispatch {
  my($self, $t_type, $m_type) = @_;
  croak "No comparator found for topic '$t_type' => match '$m_type'"
    unless $self->is_registered( $t_type, $m_type );
  my($t,$m) = @_ == 5 ?
    @_[3,4] : ( $Switch::Perlish::TOPIC, $Switch::Perlish::MATCH );

  ## XXX: Subvert the stack with a goto?
  $REGISTER{ $t_type }{ $m_type }->( $t, $m );
}

sub register {
  my($self, %comp) = @_;
  my($t_type, $m_type, $compare) = @comp{qw/ topic match compare /};

  warnings::warn("Overriding existing comparator for $t_type<=>$m_type")
    if $self->is_registered($t_type, $m_type) and warnings::enabled;

  $REGISTER{ $t_type }{ $m_type } = $compare;
  $REGISTER{ $m_type }{ $t_type } = sub { $compare->(reverse @_) }
    if exists $comp{reversible} and $comp{reversible};
}

sub register_package {
  my($self, $pkg, $topic) = @_;
  my $prefix  = defined($_[3]) ? $_[3] : '_';
  my $reverse = defined($_[4]) ? $_[4] : 0;

  croak "An empty prefix was provided (registering all subs is not desirable)"
    if length($prefix) == 0;

  ## Let perl do the look-up.
  my $tbl = do { no strict; \%{"$pkg\::"} };

  for( grep /^$prefix/, keys %$tbl  ) {
    my $sub;
    next
      unless $sub = *{$tbl->{$_}}{CODE};

    Switch::Perlish::Smatch->register(
      topic      => $topic,
      match      => substr($_, 1),
      compare    => $sub,
      reversible => $reverse,
    );
  }
}

sub is_registered {
  my($self, $t_type, $m_type) = @_;

  return ( exists $REGISTER{ $t_type } and defined $REGISTER{ $t_type } )
    if @_ == 2;
  return (     exists  $REGISTER{ $t_type } and defined $REGISTER{ $t_type }
           and exists  $REGISTER{ $t_type }{ $m_type }
           and defined $REGISTER{ $t_type }{ $m_type } )
    if @_ == 3;

  croak sprintf "Incorrect number of arguments for is_registered(%s)",
                join(', ', @_);
}

1;

=pod

=head1 NAME

Switch::Perlish::Smatch - the 'smart' behind the matching in S::P

=head1 VERSION

1.0.1 - Updated and cleaned up documentation.

=head1 SYNOPSIS

  use Switch::Perlish::Smatch 'smatch';

  print 'yep'
    if smatch $foo => \@bar;

=head1 DESCRIPTION

Given two values compare them in an intelligent fashion (i.e I)
regardless of type. This is done by discerning the types of the values and
delegating to the associated subroutine, or Cing if one isn't available.

=head2 Glossary

=over

=item comparators

When talking about the subroutine that compares the two values in the document
below it will referred to as a I

=item comparator category

A comparator category holds all the comparators for a given type.

=item comparator notation

Some handy notation for referring to specific I is
C<< FOOE=>BAR >>, where C is the topic and C is the match (i.e the
first and second arguments, respectively).

=back

=head1 METHODS

=over

=item match( $topic, $match )

Try to smart match the C<$topic> against C<$match> by delegating to the
appopriate comparator. It returns the result of the match per the comparator,
but it can always be assumed that a successful match will evaluate to I
and an unsuccessful one I. This can also be exported as C.

=item register( %hash )

The expected C<%hash> looks like this:

  topic   => $t_type,
  match   => $m_type,
  compare => $sub,

So C<$sub> will be the registered comparator when the topic type is C<$t_type>
and the matching value is of type C<$m_type> e.g

  my $foo = 'a string';
  my $bar = [qw/ an array /];
  smatch $foo, $bar;

In this case the C<$t_type> is C and the C<$m_type> is C. If
one were to override the default comparator for C<< VALUEE=>ARRAY >>
using C then it would be done like this:

  Switch::Perlish::Smatch->register(
    topic   => 'VALUE',
    match   => 'ARRAY',
    compare => sub {
      my($t, $m) = @_;
      return grep /$t/, @$m;
    },
  );

If you run the code above you should get a warning noting that there is an
existing comparator for that type combination. To suppress this and any other
warnings from this module just add C.

This method is aimed at adding comparators for objects so they can be used
seamlessly in C calls. So instead of defaulting to the existing
C comparators a user-defined comparator would be used, with more
desirable results. For more information see L
below.

If your comparator is reversible, i.e the arguments can be reversed and the
result will be the same, then you can pass in the C argument e.g


  Switch::Perlish::Smatch->register(
    topic   => 'My::Obj',
    match   => 'ARRAY',
    compare => sub {
      my($t, $m) = @_;
      return $t->cmp( $m );
    },
    reversible => 1,
  );

So both the C<< My::Obj<=>VALUE >> and C<< VALUEE=>My::Obj >> comparators
will be setup, where C<< VALUEE=>My::Obj >> will behave exactly the same as
C<< My::Obj<=>VALUE >>.

=item register_package( $package, $category[, $prefix, $reversible] );

Given the package name in C<$package>, register all subroutines beginning with
C<$prefix> (by default an underscore: C<_>) to the comparator category in
C<$category>. This is how the standard comparator functions are registered. An
empty C<$prefix> is disallowed as C must be able to know
which subroutines to register. If C<$reversible> is passed in and it evaluates
to true then all comparators for this package will be reversible.

=item is_registered( $t_type[, $m_type] )

If one argument is provided, check if there is a comparator category for
C<$t_type>. If two arguments are provided then check if the comparator for
C<< $t_type<=>$m_type >> has been registered.

=item dispatch( $t_type, $m_type[, $topic, $match] )

Dispatch to the comparator for C<$t_type> and C<$m_type>, passing along
C<$topic> and C<$match> (defaulting to C<$Switch::Perlish::TOPIC> and
C<$Switch::Perlish::MATCH>, respectively).

=back

=head2 Helper subroutines

=over

=item value_cmp($t, $m)

Given two simple values try to compare them in the most natural way i.e try to
compare 2 numbers as numbers, 2 strings as strings and any other combination do
a regexp match.

=back

=head1 FURTHER INFO

=head2 Creating a new comparator

If we have a L object and want I it to something then we need
to create a new comparator. This can be implemented in whatever
way seems most appropriate, so for the sake of this module we will be testing
for the existence of a simple value in C e.g

  sub cgi_comparator {
    my($cgi, $val) = @_;
    return defined( $cgi->param($val) );
  }

Now that we have our comparator for C<< CGIE=>VALUE >> (the above subroutine)
and we know what we're comparing (a L object and a simple value) we can
register it like this:

  use Switch::Perlish::Smatch 'smatch';

  Switch::Perlish::Smatch->register(
    topic   => 'CGI',
    match   => 'VALUE',
    compare => \&cgi_comparator,
  );

So we can now compare simple values with L objects e.g

  my $q     = CGI->new;
  my $check = $ARGV[0];
  printf "%s $check in params!\n",
         smatch($q, $check) ? 'found' : 'not found';

=head2 The default types

There are currently 8 default types, all of which have a complete set of
comparators implemented. These 8 types are:

=over

=item VALUE

This type covers simple values which are just strings or numbers.

=item UNDEF

This covers any Cs.

=item SCALAR

This covers all C references.

=item ARRAY

Covers arrays.

=item HASH

Covers hashes.

=item CODE

Covers coderefs i.e subroutines.

=item OBJECT

Covers any objects that don't have specific comparators.

=item Regexp

Covers C objects.

=back

=head2 How comparators compare

For info on how each comparator works see.
L.

=head1 TODO

=over

=item *

Add more helper subroutines for common operations default, and make them easier
to access.

=item *

Move into own module if people find it sufficiently useful.

=item *

Add object functionality perhaps (but who wants that?).

=item *

Maybe add inheritable comparators.

=item *

Set __ANON__ to comparator name for debugging purposes.

=item *

Add support for C (and possibly C) types.

=item *

Store the smatch result somewhere.

=item *

Allow for choice of which comparators are reversible in C.

=back

=head1 SEE. ALSO

L

L

L

=head1 EXPORT_OK

C (an alias to C)

C

=head1 AUTHOR

Dan Brook C<<  >>

=head1 COPYRIGHT

Copyright (c) 2006, Dan Brook. All Rights Reserved. This module is free
software. It may be used, redistributed and/or modified under the same
terms as Perl itself.

=cut