view release on metacpan or  search on metacpan

Switch.pm  view on Meta::CPAN

package Switch;

use 5.005;
use strict;
use vars qw($VERSION);
use Carp;

use if $] >= 5.011, 'deprecate';

$VERSION = '2.17';
  

# LOAD FILTERING MODULE...
use Filter::Util::Call;

sub __();

# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch

$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };

my $offset;
my $fallthrough;
my ($Perl5, $Perl6) = (0,0);

sub import
{
	$fallthrough = grep /\bfallthrough\b/, @_;
	$offset = (caller)[2]+1;
	filter_add({}) unless @_>1 && $_[1] eq 'noimport';
	my $pkg = caller;
	no strict 'refs';
	for ( qw( on_defined on_exists ) )
	{
		*{"${pkg}::$_"} = \&$_;
	}
	*{"${pkg}::__"} = \&__ if grep /__/, @_;
	$Perl6 = 1 if grep(/Perl\s*6/i, @_);
	$Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
	1;
}

sub unimport
{	
	filter_del()
}

sub filter
{
	my($self) = @_ ;
	local $Switch::file = (caller)[1];

	my $status = 1;
	$status = filter_read(1_000_000);
	return $status if $status<0;
    	$_ = filter_blocks($_,$offset);
	$_ = "# line $offset\n" . $_ if $offset; undef $offset;
	return $status;
}

use Text::Balanced ':ALL';

sub line
{
	my ($pretext,$offset) = @_;
	($pretext=~tr/\n/\n/)+($offset||0);
}

sub is_block
{
	local $SIG{__WARN__}=sub{die$@};
	local $^W=1;
	my $ishash = defined  eval 'my $hr='.$_[0];
	undef $@;
	return !$ishash;
}

my $pod_or_DATA = qr/ ^=[A-Za-z] .*? ^=cut (?![A-Za-z]) .*? $
		    | ^__(DATA|END)__\n.*
		    /smx;

my $casecounter = 1;
sub filter_blocks
{
	my ($source, $line) = @_;
	return $source unless $Perl5 && $source =~ /case|switch/
			   || $Perl6 && $source =~ /when|given|default/;
	pos $source = 0;
	my $text = "";
	component: while (pos $source < length $source)
	{
		if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
		{
			$text .= q{use Switch 'noimport'};
			next component;
		}
		my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
		if (defined $pos[0])
		{
			my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
                        my $iEol;
                        if( substr($source,$pos[4],$pos[5]) eq '/' && # 1st delimiter
                            substr($source,$pos[2],$pos[3]) eq '' && # no op like 'm'
                            index( substr($source,$pos[16],$pos[17]), 'x' ) == -1 && # no //x
                            ($iEol = index( $source, "\n", $pos[4] )) > 0         &&
                            $iEol < $pos[8] ){ # embedded newlines
                            # If this is a pattern, it isn't compatible with Switch. Backup past 1st '/'.
                            pos( $source ) = $pos[6];
			    $text .= $pre . substr($source,$pos[2],$pos[6]-$pos[2]);
			} else {
			    $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);