File Coverage

blib/lib/Switch/Perlish.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	38	42	90.4
condition	31	42	73.8
subroutine	21	21	100.0
pod	5	5	100.0
total	171	186	91.9

package Switch::Perlish;

require Exporter;
@ISA     = 'Exporter';
@EXPORT  = qw/ switch case default fallthrough stop /;
$VERSION = '1.0.5';

use Switch::Perlish::Smatch;

use strict;
use warnings;

use vars qw/ $MATCH $TOPIC $SWITCH $CASE $FALLING $CSTYLE /;

{
  package Switch::Perlish::Control::_success;
  package Switch::Perlish::Control::_fallthrough;
  package Switch::Perlish::Control::_stop;
}

use constant SUCCESS     => 'Switch::Perlish::Control::_success';
use constant FALLTHROUGH => 'Switch::Perlish::Control::_fallthrough';
use constant STOP        => 'Switch::Perlish::Control::_stop';

sub import {
  no warnings;
  $CSTYLE = pop(@_) eq 'C';
  Switch::Perlish->export_to_level(1, @_);
}

use Carp 'croak';
use Scalar::Util qw/ reftype blessed /;

sub switch {
  local($TOPIC, $SWITCH)  = @_;

  croak "Invalid code block provided: '$SWITCH'"
    unless reftype($SWITCH) eq 'CODE';

  ## Restore this if we exit successfully so as not to make debugging trickier.
  my $olderr = $@;

  ## Topicalize the topic for the switch block.
  local *_ = \$TOPIC;

  ## We're not falling through until a successful match.
  local $FALLING = 0;

  ## How the switch statement is evaluted:
  ## A successful case (that doesn't fallthrough) will leave the block by
  ## throwing an error object blessed into SUCCESS control exception. However,
  ## the user might want to return early for whatever reason, so keep that
  ## result too.
  my @result = eval { $SWITCH->() };
  my $err    = $@;

  ## If something was returned from the block explicitly or a case
  ## succeeded then try to return what seems most appropriate.
  if( ( @result and !$err ) or _left_ok($err) ) {
    $@ = $olderr;
    my @r = @result ? @result : @$err;
    return defined wantarray ? wantarray ? @r : $r[-1] : ();
  }

  die $err
    if $@;
}

sub _called_by {
  my $name  = $_[0];
  my $depth = defined( $_[1] ) ? $_[1] : 4;
  no warnings 'uninitialized';
  return +(caller $depth)[3] =~ /::\Q$name\E$/;
}

## Did we leave the switch() from a control exception?
sub _left_ok {
  return blessed($_[0]) and $_[0]->isa(SUCCESS)
                         or $_[0]->isa(STOP);
}

## Exit the switch block and set $@ to a S::P::_success control exception.
## NB: This blessing trickery is for people who want the result propagated.
sub _end_case { die bless \@_, SUCCESS }

sub fallthrough {
  ## make sure we're not called out of context
  croak "Not called within a case statement"
    if !_called_by(case => 5);
  die bless( \do{
    my $msg = "The fallthrough control exception from Switch::Perlish"
  }, FALLTHROUGH );
}

sub stop {
  ## Make sure this isn't called out of context.
  croak "Not called within a case statement"
    if !_called_by(case => 5);
  ## Was, "The stop control exception from Switch::Perlish", but that could be
  ## assigned to which isn't expected behaviour in the case of stop;.
  die bless([], STOP );
}

sub _exec_block {
  my @ret = eval { $CASE->() };

  ## Check for fallthrough control exception.
  return
    if blessed($@) and $@->isa(FALLTHROUGH);

  ## Check for stop control exception.
  die $@
    if blessed($@) and $@->isa(STOP);

  ## Propagate non-control exception.
  die $@
    if $@;

  _end_case @ret
    unless $CSTYLE and $FALLING and !_called_by(default => 2);

  return @ret;
}

sub case {
  ## If you want smatching, use S::P::Smatch::match not S::P::case.
  croak "Not called within a switch statement\n"
    if !_called_by('switch');

  local($MATCH, $CASE) = @_;

  croak "No case block provided"
    if !defined($CASE) and !$CSTYLE;

  ## Single arg case and using CSTYLE and we're falling.
  return
    if $CSTYLE and $FALLING and @_ == 1;

  return
    ## keep going if we're falling, otherwise smatch
    unless $CSTYLE and $FALLING
        or Switch::Perlish::Smatch->match($TOPIC, $MATCH);

  ## There's been a match, so keep on falling.
  $FALLING = 1
    if $CSTYLE;

  ## Single arg case and using CSTYLE and we matched.
  return
    if $CSTYLE and $FALLING and @_ == 1;

  _exec_block;
}

sub default {
  ## Make sure we're in a switch block.
  croak "Not called within a switch statement\n"
    if !_called_by('switch');

  local $CASE = $_[0];

  _exec_block;
}

1;

=pod

=head1 NAME

Switch::Perlish - A Perlish implementation of the C statement.

=head1 VERSION

1.0.5 - Mostly cosmetic changes for this release.

=head1 SYNOPSIS

  use Switch::Perlish;

  switch $var, sub {
    case 'foo',
      sub { print "$var is equal to 'foo'\n" };
    case 42,
      sub { print "$var is equal to 42\n";
            fallthrough };
    case [qw/ foo bar baz /],
      sub { print "$var found in list\n" };
    case { foo => 'bar' },
      sub { print "$var key found in hash\n" };
    case \&func,
      sub { print "$var as arg to func() returned true\n" };
    case $obj,
      sub { print "$var is method in $obj and returned true\n" };
    case qr/\bfoo\b/,
      sub { print "$var matched against foo\n" };
    default
      sub { print "$var did not find a match\n" };
  };

=head1 BACKGROUND

If you're unfamiliar with C then this is the best place to start. A
C statement is essentially syntactic sugar for an C/C/C
chain where the same C<$variable> is tested in every conditional e.g:

  my $foo = 'a string';
  if($foo eq 'something') {
    print '$foo matched "something"';
  } elsif($foo eq 'a string') {
    print '$foo matched "a string"';
  } else {
    print '$foo matched nothing';
  }

This simply matches C<$foo> against a series of strings, then defaulting to the
last C block if nothing matched. An equivalent C statement (using
this module) would be:

  use Switch::Perlish;
  my $foo = 'a string';
  switch $foo, sub {
    case 'something',
      sub { print '$foo matched "something"' };
    case 'a string',
      sub { print '$foo matched "a string"'  };
    default
      sub { print '$foo matched nothing' };
  };

So the first argument to C is the thing to be tested (in the code above,
C<$foo>), and the second argument is the block of tests. Each C statement
matches its first argument against C<$foo>, and if the match is successful,
the associated block is executed, so running the above code outputs: C<$foo
matched "a string">.  Note the use of semi-colon at the end of the C,
C and C calls - they're just simple subroutine calls.

=head1 DESCRIPTION

This is a Perl-oriented implementation of the C statement. It uses
smart-matching in Cs which can be configured and extended by the user.
There is no magical syntax so C/C/C expect coderefs,
which are most simply provided by anonymous subroutines. By default successful
C statements do not fall through[1]. To fall through a C block
call the C subroutine explicitly. For C style C
behaviour[2] simply call the module with an upper-case I i.e

  use Switch::Perlish 'C';

I<< [1] To 'fall through' in a C block means that the C block
isn't exited upon success. >>

I<< [2] upon a C succesfully matching all subsequent Cs succeed; to
break out from the current C completely use C. >>

=head2 Smart Matching

The idea behind I is that the given values are matched
in an intelligent manner, so as to get a meaningful result I
of the values' types. This allows for flexible code and a certain amount of
"just do it" when using I. Below is a basic example using
I (which is done implictly in C) where a simple value
is being matched against an array e.g

  use Switch::Perlish;

  my $num = $ARGV[0];

  switch $num, sub {
    case undef,
      sub { die "Usage: $0 NUM\n" };
    case [0 .. 10],
      sub { print "Your number was between 0 and 10" };
    case [11 .. 100],
      sub { print "Your number was between 11 and 100" };
    case [101 .. 1000],
      sub { print "Your number was between 101 and 1000" };
    default
      sub { print "Your number was less than 0 or greater than 1000" };
  };

So here the I is checking for the existence of C<$num> in the
provided arrays. In the above code I happen to be used, but any array
would suffice. To see how different value types compare with each other see.
L, which provides descriptions for all
the default comparators.

The code behind this I can be found in
L which itself delegates to the appropriate comparator
subroutine depending on the value types. See L for more
details on the I implementation and how it can be extended.

=head1 COMPARISON

Because there is an existing module which implements C this section
intends to provide clarification of the differences that module, L,
and this one.

=head2 Native vs. New

To create a more natural C syntax, L uses source filters[3],
which facilitate the creation of this natural syntax. C
however uses the native syntax of perl, so what you code is what you see.
The big advantage of source filtering is the ability to create new syntax,
but it has several disadvantages - the new syntax can conflict with, and
break, existing code, the filtered code can be difficult to debug and because
you can't easily see the post-filtered code it can be difficult to integrate
into production code. The Itre> for this module is to have
the syntax of C without the baggage that goes with filtered code.

=head2 Extensibility

The L module deals with the Perl's types superbly, however, that is all,
so there is no extensibility as such. This module was designed from the outset
to allow an extensibilty of how types are dealt with, i.e how they are compared,
and this is done through the companion module L.

=head2 The C keyword

Unlike L, C requires the use of the the C keyword
when creating blocks. This is because there is no standard way of magically
coercing bare blocks into closures, unless one uses the C<(E)> prototype,
and that is only applicable where it is the first argument. Also, prototypes are
too restrictive for what is intended as a very I module e.g

  $ perl -e 'sub f(&) { print $_[0]->() } sub g{'foo'} my $r = \&g; f $r'
  Type of arg 1 to main::f must be block or sub {} (not private variable)
  at -e line 1, at EOF
  Execution of -e aborted due to compilation errors.

So, for now, 3 extra keystrokes are necessary when using blocks with
C.

I<< [3] see. L for more info on source filters >>.

=head1 SUBROUTINES

=over

=item C<< switch( $topic, $block ) >>

Execute the given C<$block> allowing C statements to access the C<$topic>.
This, along with C and C, will also attempt to return in the same
manner as normal subroutines e.g you can assign to the result of them.

=item C<< case( $match, $block ) >>

If the current C<$topic> successfully I against C<$match> then
execute C<$block> and exit from current C, but if using C style
C behaviour, then continue executing the block and all subsequent
C C<$block>s until the end of the current C or a call to C.
Also, if using C style C behaviour then C<$block> is optional. I:
this subroutine cannot be called outside of C, if you want to use
I functionality, see. L.

=item C<< default( $block ) >>

Execute C<$block> and exit from C. I: this subroutine cannot be
called outside of C.

=item C<< fallthrough() >>

Fall through the the current C block i.e continue to evaluate the rest of
the C block. I: this subroutine cannot be called outside of C.

=item C<< stop() >>

Use in C blocks to exit the current C block, ideally when used
with the C style behaviour as it mimics C's C. I: this
subroutine cannot be called outside of C.

=back

=head2 Globals

=over

=item C<$SWITCH>

The current C block.

=item C<$CASE>

The current C block.

=item C<$TOPIC>

The current topic block, also aliased to C<$_>.

=item C<$MATCH>

The current thing being matched against.

=item C<$CSTYLE>

If C is called with the I argument, this is set to
true and C style C behaviour is enabled.

=item C<$FALLING>

Set to true when falling through the current C block i.e set to true
when C has been called.

=back

=head1 SEE. ALSO

L

L

L

L

L

=head1 TODO

=over

=item *

Implement localizing comparators

=item *

Test with earlier versions of C

=item *

Drop C for compatibility with older perls?

=item *

Allow lists as the topic and/or cases to match against

=back

=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