1package Switch;
2
3use strict;
4use vars qw($VERSION);
5use Carp;
6
7$VERSION = '2.10';
8
9
10# LOAD FILTERING MODULE...
11use Filter::Util::Call;
12
13sub __();
14
15# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
16
17$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
18
19my $offset;
20my $fallthrough;
21my ($Perl5, $Perl6) = (0,0);
22
23sub import
24{
25	$fallthrough = grep /\bfallthrough\b/, @_;
26	$offset = (caller)[2]+1;
27	filter_add({}) unless @_>1 && $_[1] eq 'noimport';
28	my $pkg = caller;
29	no strict 'refs';
30	for ( qw( on_defined on_exists ) )
31	{
32		*{"${pkg}::$_"} = \&$_;
33	}
34	*{"${pkg}::__"} = \&__ if grep /__/, @_;
35	$Perl6 = 1 if grep(/Perl\s*6/i, @_);
36	$Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
37	1;
38}
39
40sub unimport
41{
42	filter_del()
43}
44
45sub filter
46{
47	my($self) = @_ ;
48	local $Switch::file = (caller)[1];
49
50	my $status = 1;
51	$status = filter_read(1_000_000);
52	return $status if $status<0;
53    	$_ = filter_blocks($_,$offset);
54	$_ = "# line $offset\n" . $_ if $offset; undef $offset;
55	return $status;
56}
57
58use Text::Balanced ':ALL';
59
60sub line
61{
62	my ($pretext,$offset) = @_;
63	($pretext=~tr/\n/\n/)+($offset||0);
64}
65
66sub is_block
67{
68	local $SIG{__WARN__}=sub{die$@};
69	local $^W=1;
70	my $ishash = defined  eval 'my $hr='.$_[0];
71	undef $@;
72	return !$ishash;
73}
74
75
76my $EOP = qr/\n\n|\Z/;
77my $CUT = qr/\n=cut.*$EOP/;
78my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
79                    | ^=pod .*? $CUT
80                    | ^=for .*? $EOP
81                    | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
82                    | ^__(DATA|END)__\n.*
83                    /smx;
84
85my $casecounter = 1;
86sub filter_blocks
87{
88	my ($source, $line) = @_;
89	return $source unless $Perl5 && $source =~ /case|switch/
90			   || $Perl6 && $source =~ /when|given|default/;
91	pos $source = 0;
92	my $text = "";
93	component: while (pos $source < length $source)
94	{
95		if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
96		{
97			$text .= q{use Switch 'noimport'};
98			next component;
99		}
100		my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
101		if (defined $pos[0])
102		{
103			my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
104			$text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
105			next component;
106		}
107		if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
108			next component;
109		}
110		@pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
111		if (defined $pos[0])
112		{
113			$text .= " " if $pos[0] < $pos[2];
114			$text .= substr($source,$pos[0],$pos[4]-$pos[0]);
115			next component;
116		}
117
118		if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
119		 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
120		 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
121		{
122			my $keyword = $3;
123			my $arg = $4;
124			$text .= $1.$2.'S_W_I_T_C_H: while (1) ';
125			unless ($arg) {
126				@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
127				or do {
128					die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
129				};
130				$arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
131			}
132			$arg =~ s {^\s*[(]\s*%}   { ( \\\%}	||
133			$arg =~ s {^\s*[(]\s*m\b} { ( qr}	||
134			$arg =~ s {^\s*[(]\s*/}   { ( qr/}	||
135			$arg =~ s {^\s*[(]\s*qw}  { ( \\qw};
136			@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
137			or do {
138				die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
139			};
140			my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
141			$code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
142			$text .= $code . 'continue {last}';
143			next component;
144		}
145		elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
146		    || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
147		    || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
148		{
149			my $keyword = $2;
150			$text .= $1 . ($keyword eq "default"
151					? "if (1)"
152					: "if (Switch::case");
153
154			if ($keyword eq "default") {
155				# Nothing to do
156			}
157			elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
158				my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
159				$text .= " " if $pos[0] < $pos[2];
160				$text .= "sub " if is_block $code;
161				$text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
162			}
163			elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
164				my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
165				$code =~ s {^\s*[(]\s*%}   { ( \\\%}	||
166				$code =~ s {^\s*[(]\s*m\b} { ( qr}	||
167				$code =~ s {^\s*[(]\s*/}   { ( qr/}	||
168				$code =~ s {^\s*[(]\s*qw}  { ( \\qw};
169				$text .= " " if $pos[0] < $pos[2];
170				$text .= "$code)";
171			}
172			elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
173				my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
174				$code =~ s {^\s*%}  { \%}	||
175				$code =~ s {^\s*@}  { \@};
176				$text .= " " if $pos[0] < $pos[2];
177				$text .= "$code)";
178			}
179			elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
180				my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
181				$code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
182				$code =~ s {^\s*m}  { qr}	||
183				$code =~ s {^\s*/}  { qr/}	||
184				$code =~ s {^\s*qw} { \\qw};
185				$text .= " " if $pos[0] < $pos[2];
186				$text .= "$code)";
187			}
188			elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
189			   ||  $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
190				my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
191				$text .= ' \\' if $2 eq '%';
192				$text .= " $code)";
193			}
194			else {
195				die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
196			}
197
198		        die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
199				unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
200
201			do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
202			or do {
203				if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
204					$casecounter++;
205					next component;
206				}
207				die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
208			};
209			my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
210			$code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
211				unless $fallthrough;
212			$text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
213			$casecounter++;
214			next component;
215		}
216
217		$source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
218		$text .= $1;
219	}
220	$text;
221}
222
223
224
225sub in
226{
227	my ($x,$y) = @_;
228	my @numy;
229	for my $nextx ( @$x )
230	{
231		my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
232		for my $j ( 0..$#$y )
233		{
234			my $nexty = $y->[$j];
235			push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
236				if @numy <= $j;
237			return 1 if $numx && $numy[$j] && $nextx==$nexty
238			         || $nextx eq $nexty;
239
240		}
241	}
242	return "";
243}
244
245sub on_exists
246{
247	my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
248	[ keys %$ref ]
249}
250
251sub on_defined
252{
253	my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
254	[ grep { defined $ref->{$_} } keys %$ref ]
255}
256
257sub switch(;$)
258{
259	my ($s_val) = @_ ? $_[0] : $_;
260	my $s_ref = ref $s_val;
261
262	if ($s_ref eq 'CODE')
263	{
264		$::_S_W_I_T_C_H =
265		      sub { my $c_val = $_[0];
266			    return $s_val == $c_val  if ref $c_val eq 'CODE';
267			    return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
268			    return $s_val->($c_val);
269			  };
270	}
271	elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0)	# NUMERIC SCALAR
272	{
273		$::_S_W_I_T_C_H =
274		      sub { my $c_val = $_[0];
275			    my $c_ref = ref $c_val;
276			    return $s_val == $c_val 	if $c_ref eq ""
277							&& defined $c_val
278							&& (~$c_val&$c_val) eq 0;
279			    return $s_val eq $c_val 	if $c_ref eq "";
280			    return in([$s_val],$c_val)	if $c_ref eq 'ARRAY';
281			    return $c_val->($s_val)	if $c_ref eq 'CODE';
282			    return $c_val->call($s_val)	if $c_ref eq 'Switch';
283			    return scalar $s_val=~/$c_val/
284							if $c_ref eq 'Regexp';
285			    return scalar $c_val->{$s_val}
286							if $c_ref eq 'HASH';
287		            return;
288			  };
289	}
290	elsif ($s_ref eq "")				# STRING SCALAR
291	{
292		$::_S_W_I_T_C_H =
293		      sub { my $c_val = $_[0];
294			    my $c_ref = ref $c_val;
295			    return $s_val eq $c_val 	if $c_ref eq "";
296			    return in([$s_val],$c_val)	if $c_ref eq 'ARRAY';
297			    return $c_val->($s_val)	if $c_ref eq 'CODE';
298			    return $c_val->call($s_val)	if $c_ref eq 'Switch';
299			    return scalar $s_val=~/$c_val/
300							if $c_ref eq 'Regexp';
301			    return scalar $c_val->{$s_val}
302							if $c_ref eq 'HASH';
303		            return;
304			  };
305	}
306	elsif ($s_ref eq 'ARRAY')
307	{
308		$::_S_W_I_T_C_H =
309		      sub { my $c_val = $_[0];
310			    my $c_ref = ref $c_val;
311			    return in($s_val,[$c_val]) 	if $c_ref eq "";
312			    return in($s_val,$c_val)	if $c_ref eq 'ARRAY';
313			    return $c_val->(@$s_val)	if $c_ref eq 'CODE';
314			    return $c_val->call(@$s_val)
315							if $c_ref eq 'Switch';
316			    return scalar grep {$_=~/$c_val/} @$s_val
317							if $c_ref eq 'Regexp';
318			    return scalar grep {$c_val->{$_}} @$s_val
319							if $c_ref eq 'HASH';
320		            return;
321			  };
322	}
323	elsif ($s_ref eq 'Regexp')
324	{
325		$::_S_W_I_T_C_H =
326		      sub { my $c_val = $_[0];
327			    my $c_ref = ref $c_val;
328			    return $c_val=~/s_val/ 	if $c_ref eq "";
329			    return scalar grep {$_=~/s_val/} @$c_val
330							if $c_ref eq 'ARRAY';
331			    return $c_val->($s_val)	if $c_ref eq 'CODE';
332			    return $c_val->call($s_val)	if $c_ref eq 'Switch';
333			    return $s_val eq $c_val	if $c_ref eq 'Regexp';
334			    return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
335							if $c_ref eq 'HASH';
336		            return;
337			  };
338	}
339	elsif ($s_ref eq 'HASH')
340	{
341		$::_S_W_I_T_C_H =
342		      sub { my $c_val = $_[0];
343			    my $c_ref = ref $c_val;
344			    return $s_val->{$c_val} 	if $c_ref eq "";
345			    return scalar grep {$s_val->{$_}} @$c_val
346							if $c_ref eq 'ARRAY';
347			    return $c_val->($s_val)	if $c_ref eq 'CODE';
348			    return $c_val->call($s_val)	if $c_ref eq 'Switch';
349			    return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
350							if $c_ref eq 'Regexp';
351			    return $s_val==$c_val	if $c_ref eq 'HASH';
352		            return;
353			  };
354	}
355	elsif ($s_ref eq 'Switch')
356	{
357		$::_S_W_I_T_C_H =
358		      sub { my $c_val = $_[0];
359			    return $s_val == $c_val  if ref $c_val eq 'Switch';
360			    return $s_val->call(@$c_val)
361						     if ref $c_val eq 'ARRAY';
362			    return $s_val->call($c_val);
363			  };
364	}
365	else
366	{
367		croak "Cannot switch on $s_ref";
368	}
369	return 1;
370}
371
372sub case($) { local $SIG{__WARN__} = \&carp;
373	      $::_S_W_I_T_C_H->(@_); }
374
375# IMPLEMENT __
376
377my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
378
379sub __() { $placeholder }
380
381sub __arg($)
382{
383	my $index = $_[0]+1;
384	bless { arity=>0, impl=>sub{$_[$index]} };
385}
386
387sub hosub(&@)
388{
389	# WRITE THIS
390}
391
392sub call
393{
394	my ($self,@args) = @_;
395	return $self->{impl}->(0,@args);
396}
397
398sub meta_bop(&)
399{
400	my ($op) = @_;
401	sub
402	{
403		my ($left, $right, $reversed) = @_;
404		($right,$left) = @_ if $reversed;
405
406		my $rop = ref $right eq 'Switch'
407			? $right
408			: bless { arity=>0, impl=>sub{$right} };
409
410		my $lop = ref $left eq 'Switch'
411			? $left
412			: bless { arity=>0, impl=>sub{$left} };
413
414		my $arity = $lop->{arity} + $rop->{arity};
415
416		return bless {
417				arity => $arity,
418				impl  => sub { my $start = shift;
419					       return $op->($lop->{impl}->($start,@_),
420						            $rop->{impl}->($start+$lop->{arity},@_));
421					     }
422			     };
423	};
424}
425
426sub meta_uop(&)
427{
428	my ($op) = @_;
429	sub
430	{
431		my ($left) = @_;
432
433		my $lop = ref $left eq 'Switch'
434			? $left
435			: bless { arity=>0, impl=>sub{$left} };
436
437		my $arity = $lop->{arity};
438
439		return bless {
440				arity => $arity,
441				impl  => sub { $op->($lop->{impl}->(@_)) }
442			     };
443	};
444}
445
446
447use overload
448	"+"	=> 	meta_bop {$_[0] + $_[1]},
449	"-"	=> 	meta_bop {$_[0] - $_[1]},
450	"*"	=>  	meta_bop {$_[0] * $_[1]},
451	"/"	=>  	meta_bop {$_[0] / $_[1]},
452	"%"	=>  	meta_bop {$_[0] % $_[1]},
453	"**"	=>  	meta_bop {$_[0] ** $_[1]},
454	"<<"	=>  	meta_bop {$_[0] << $_[1]},
455	">>"	=>  	meta_bop {$_[0] >> $_[1]},
456	"x"	=>  	meta_bop {$_[0] x $_[1]},
457	"."	=>  	meta_bop {$_[0] . $_[1]},
458	"<"	=>  	meta_bop {$_[0] < $_[1]},
459	"<="	=>  	meta_bop {$_[0] <= $_[1]},
460	">"	=>  	meta_bop {$_[0] > $_[1]},
461	">="	=>  	meta_bop {$_[0] >= $_[1]},
462	"=="	=>  	meta_bop {$_[0] == $_[1]},
463	"!="	=>  	meta_bop {$_[0] != $_[1]},
464	"<=>"	=>  	meta_bop {$_[0] <=> $_[1]},
465	"lt"	=>  	meta_bop {$_[0] lt $_[1]},
466	"le"	=> 	meta_bop {$_[0] le $_[1]},
467	"gt"	=> 	meta_bop {$_[0] gt $_[1]},
468	"ge"	=> 	meta_bop {$_[0] ge $_[1]},
469	"eq"	=> 	meta_bop {$_[0] eq $_[1]},
470	"ne"	=> 	meta_bop {$_[0] ne $_[1]},
471	"cmp"	=> 	meta_bop {$_[0] cmp $_[1]},
472	"\&"	=> 	meta_bop {$_[0] & $_[1]},
473	"^"	=> 	meta_bop {$_[0] ^ $_[1]},
474	"|"	=>	meta_bop {$_[0] | $_[1]},
475	"atan2"	=>	meta_bop {atan2 $_[0], $_[1]},
476
477	"neg"	=>	meta_uop {-$_[0]},
478	"!"	=>	meta_uop {!$_[0]},
479	"~"	=>	meta_uop {~$_[0]},
480	"cos"	=>	meta_uop {cos $_[0]},
481	"sin"	=>	meta_uop {sin $_[0]},
482	"exp"	=>	meta_uop {exp $_[0]},
483	"abs"	=>	meta_uop {abs $_[0]},
484	"log"	=>	meta_uop {log $_[0]},
485	"sqrt"  =>	meta_uop {sqrt $_[0]},
486	"bool"  =>	sub { croak "Can't use && or || in expression containing __" },
487
488	#	"&()"	=>	sub { $_[0]->{impl} },
489
490	#	"||"	=>	meta_bop {$_[0] || $_[1]},
491	#	"&&"	=>	meta_bop {$_[0] && $_[1]},
492	# fallback => 1,
493	;
4941;
495
496__END__
497
498
499=head1 NAME
500
501Switch - A switch statement for Perl
502
503=head1 VERSION
504
505This document describes version 2.10 of Switch,
506released Dec 29, 2003.
507
508=head1 SYNOPSIS
509
510	use Switch;
511
512	switch ($val) {
513
514		case 1		{ print "number 1" }
515		case "a"	{ print "string a" }
516		case [1..10,42]	{ print "number in list" }
517		case (@array)	{ print "number in list" }
518		case /\w+/	{ print "pattern" }
519		case qr/\w+/	{ print "pattern" }
520		case (%hash)	{ print "entry in hash" }
521		case (\%hash)	{ print "entry in hash" }
522		case (\&sub)	{ print "arg to subroutine" }
523		else		{ print "previous case not true" }
524	}
525
526=head1 BACKGROUND
527
528[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
529and wherefores of this control structure]
530
531In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
532it is useful to generalize this notion of distributed conditional
533testing as far as possible. Specifically, the concept of "matching"
534between the switch value and the various case values need not be
535restricted to numeric (or string or referential) equality, as it is in other
536languages. Indeed, as Table 1 illustrates, Perl
537offers at least eighteen different ways in which two values could
538generate a match.
539
540	Table 1: Matching a switch value ($s) with a case value ($c)
541
542        Switch  Case    Type of Match Implied   Matching Code
543        Value   Value
544        ======  =====   =====================   =============
545
546        number  same    numeric or referential  match if $s == $c;
547        or ref          equality
548
549	object  method	result of method call   match if $s->$c();
550	ref     name 				match if defined $s->$c();
551		or ref
552
553        other   other   string equality         match if $s eq $c;
554        non-ref non-ref
555        scalar  scalar
556
557        string  regexp  pattern match           match if $s =~ /$c/;
558
559        array   scalar  array entry existence   match if 0<=$c && $c<@$s;
560        ref             array entry definition  match if defined $s->[$c];
561                        array entry truth       match if $s->[$c];
562
563        array   array   array intersection      match if intersects(@$s, @$c);
564        ref     ref     (apply this table to
565                         all pairs of elements
566                         $s->[$i] and
567                         $c->[$j])
568
569        array   regexp  array grep              match if grep /$c/, @$s;
570        ref
571
572        hash    scalar  hash entry existence    match if exists $s->{$c};
573        ref             hash entry definition   match if defined $s->{$c};
574                        hash entry truth        match if $s->{$c};
575
576        hash    regexp  hash grep               match if grep /$c/, keys %$s;
577        ref
578
579        sub     scalar  return value defn       match if defined $s->($c);
580        ref             return value truth      match if $s->($c);
581
582        sub     array   return value defn       match if defined $s->(@$c);
583        ref     ref     return value truth      match if $s->(@$c);
584
585
586In reality, Table 1 covers 31 alternatives, because only the equality and
587intersection tests are commutative; in all other cases, the roles of
588the C<$s> and C<$c> variables could be reversed to produce a
589different test. For example, instead of testing a single hash for
590the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
591one could test for the existence of a single key in a series of hashes
592(C<match if exists $c-E<gt>{$s}>).
593
594As L<perltodo> observes, a Perl case mechanism must support all these
595"ways to do it".
596
597
598=head1 DESCRIPTION
599
600The Switch.pm module implements a generalized case mechanism that covers
601the numerous possible combinations of switch and case values described above.
602
603The module augments the standard Perl syntax with two new control
604statements: C<switch> and C<case>. The C<switch> statement takes a
605single scalar argument of any type, specified in parentheses.
606C<switch> stores this value as the
607current switch value in a (localized) control variable.
608The value is followed by a block which may contain one or more
609Perl statements (including the C<case> statement described below).
610The block is unconditionally executed once the switch value has
611been cached.
612
613A C<case> statement takes a single scalar argument (in mandatory
614parentheses if it's a variable; otherwise the parens are optional) and
615selects the appropriate type of matching between that argument and the
616current switch value. The type of matching used is determined by the
617respective types of the switch value and the C<case> argument, as
618specified in Table 1. If the match is successful, the mandatory
619block associated with the C<case> statement is executed.
620
621In most other respects, the C<case> statement is semantically identical
622to an C<if> statement. For example, it can be followed by an C<else>
623clause, and can be used as a postfix statement qualifier.
624
625However, when a C<case> block has been executed control is automatically
626transferred to the statement after the immediately enclosing C<switch>
627block, rather than to the next statement within the block. In other
628words, the success of any C<case> statement prevents other cases in the
629same scope from executing. But see L<"Allowing fall-through"> below.
630
631Together these two new statements provide a fully generalized case
632mechanism:
633
634        use Switch;
635
636        # AND LATER...
637
638        %special = ( woohoo => 1,  d'oh => 1 );
639
640        while (<>) {
641            switch ($_) {
642
643                case (%special) { print "homer\n"; }      # if $special{$_}
644                case /a-z/i     { print "alpha\n"; }      # if $_ =~ /a-z/i
645                case [1..9]     { print "small num\n"; }  # if $_ in [1..9]
646
647                case { $_[0] >= 10 } {                    # if $_ >= 10
648                    my $age = <>;
649                    switch (sub{ $_[0] < $age } ) {
650
651                        case 20  { print "teens\n"; }     # if 20 < $age
652                        case 30  { print "twenties\n"; }  # if 30 < $age
653                        else     { print "history\n"; }
654                    }
655                }
656
657                print "must be punctuation\n" case /\W/;  # if $_ ~= /\W/
658        }
659
660Note that C<switch>es can be nested within C<case> (or any other) blocks,
661and a series of C<case> statements can try different types of matches
662-- hash membership, pattern match, array intersection, simple equality,
663etc. -- against the same switch value.
664
665The use of intersection tests against an array reference is particularly
666useful for aggregating integral cases:
667
668        sub classify_digit
669        {
670                switch ($_[0]) { case 0            { return 'zero' }
671                                 case [2,4,6,8]    { return 'even' }
672                                 case [1,3,4,7,9]  { return 'odd' }
673                                 case /[A-F]/i     { return 'hex' }
674                               }
675        }
676
677
678=head2 Allowing fall-through
679
680Fall-though (trying another case after one has already succeeded)
681is usually a Bad Idea in a switch statement. However, this
682is Perl, not a police state, so there I<is> a way to do it, if you must.
683
684If a C<case> block executes an untargetted C<next>, control is
685immediately transferred to the statement I<after> the C<case> statement
686(i.e. usually another case), rather than out of the surrounding
687C<switch> block.
688
689For example:
690
691        switch ($val) {
692                case 1      { handle_num_1(); next }    # and try next case...
693                case "1"    { handle_str_1(); next }    # and try next case...
694                case [0..9] { handle_num_any(); }       # and we're done
695                case /\d/   { handle_dig_any(); next }  # and try next case...
696                case /.*/   { handle_str_any(); next }  # and try next case...
697        }
698
699If $val held the number C<1>, the above C<switch> block would call the
700first three C<handle_...> subroutines, jumping to the next case test
701each time it encountered a C<next>. After the thrid C<case> block
702was executed, control would jump to the end of the enclosing
703C<switch> block.
704
705On the other hand, if $val held C<10>, then only the last two C<handle_...>
706subroutines would be called.
707
708Note that this mechanism allows the notion of I<conditional fall-through>.
709For example:
710
711        switch ($val) {
712                case [0..9] { handle_num_any(); next if $val < 7; }
713                case /\d/   { handle_dig_any(); }
714        }
715
716If an untargetted C<last> statement is executed in a case block, this
717immediately transfers control out of the enclosing C<switch> block
718(in other words, there is an implicit C<last> at the end of each
719normal C<case> block). Thus the previous example could also have been
720written:
721
722        switch ($val) {
723                case [0..9] { handle_num_any(); last if $val >= 7; next; }
724                case /\d/   { handle_dig_any(); }
725        }
726
727
728=head2 Automating fall-through
729
730In situations where case fall-through should be the norm, rather than an
731exception, an endless succession of terminal C<next>s is tedious and ugly.
732Hence, it is possible to reverse the default behaviour by specifying
733the string "fallthrough" when importing the module. For example, the
734following code is equivalent to the first example in L<"Allowing fall-through">:
735
736        use Switch 'fallthrough';
737
738        switch ($val) {
739                case 1      { handle_num_1(); }
740                case "1"    { handle_str_1(); }
741                case [0..9] { handle_num_any(); last }
742                case /\d/   { handle_dig_any(); }
743                case /.*/   { handle_str_any(); }
744        }
745
746Note the explicit use of a C<last> to preserve the non-fall-through
747behaviour of the third case.
748
749
750
751=head2 Alternative syntax
752
753Perl 6 will provide a built-in switch statement with essentially the
754same semantics as those offered by Switch.pm, but with a different
755pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
756C<case> will be pronounced C<when>. In addition, the C<when> statement
757will not require switch or case values to be parenthesized.
758
759This future syntax is also (largely) available via the Switch.pm module, by
760importing it with the argument C<"Perl6">.  For example:
761
762        use Switch 'Perl6';
763
764        given ($val) {
765                when 1       { handle_num_1(); }
766                when ($str1) { handle_str_1(); }
767                when [0..9]  { handle_num_any(); last }
768                when /\d/    { handle_dig_any(); }
769                when /.*/    { handle_str_any(); }
770                default      { handle anything else; }
771        }
772
773Note that scalars still need to be parenthesized, since they would be
774ambiguous in Perl 5.
775
776Note too that you can mix and match both syntaxes by importing the module
777with:
778
779	use Switch 'Perl5', 'Perl6';
780
781
782=head2 Higher-order Operations
783
784One situation in which C<switch> and C<case> do not provide a good
785substitute for a cascaded C<if>, is where a switch value needs to
786be tested against a series of conditions. For example:
787
788        sub beverage {
789            switch (shift) {
790
791                case sub { $_[0] < 10 }  { return 'milk' }
792                case sub { $_[0] < 20 }  { return 'coke' }
793                case sub { $_[0] < 30 }  { return 'beer' }
794                case sub { $_[0] < 40 }  { return 'wine' }
795                case sub { $_[0] < 50 }  { return 'malt' }
796                case sub { $_[0] < 60 }  { return 'Moet' }
797                else                     { return 'milk' }
798            }
799        }
800
801The need to specify each condition as a subroutine block is tiresome. To
802overcome this, when importing Switch.pm, a special "placeholder"
803subroutine named C<__> [sic] may also be imported. This subroutine
804converts (almost) any expression in which it appears to a reference to a
805higher-order function. That is, the expression:
806
807        use Switch '__';
808
809        __ < 2 + __
810
811is equivalent to:
812
813        sub { $_[0] < 2 + $_[1] }
814
815With C<__>, the previous ugly case statements can be rewritten:
816
817        case  __ < 10  { return 'milk' }
818        case  __ < 20  { return 'coke' }
819        case  __ < 30  { return 'beer' }
820        case  __ < 40  { return 'wine' }
821        case  __ < 50  { return 'malt' }
822        case  __ < 60  { return 'Moet' }
823        else           { return 'milk' }
824
825The C<__> subroutine makes extensive use of operator overloading to
826perform its magic. All operations involving __ are overloaded to
827produce an anonymous subroutine that implements a lazy version
828of the original operation.
829
830The only problem is that operator overloading does not allow the
831boolean operators C<&&> and C<||> to be overloaded. So a case statement
832like this:
833
834        case  0 <= __ && __ < 10  { return 'digit' }
835
836doesn't act as expected, because when it is
837executed, it constructs two higher order subroutines
838and then treats the two resulting references as arguments to C<&&>:
839
840        sub { 0 <= $_[0] } && sub { $_[0] < 10 }
841
842This boolean expression is inevitably true, since both references are
843non-false. Fortunately, the overloaded C<'bool'> operator catches this
844situation and flags it as a error.
845
846=head1 DEPENDENCIES
847
848The module is implemented using Filter::Util::Call and Text::Balanced
849and requires both these modules to be installed.
850
851=head1 AUTHOR
852
853Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
854Garcia-Suarez (rgarciasuarez@free.fr).
855
856=head1 BUGS
857
858There are undoubtedly serious bugs lurking somewhere in code this funky :-)
859Bug reports and other feedback are most welcome.
860
861=head1 LIMITATIONS
862
863Due to the heuristic nature of Switch.pm's source parsing, the presence
864of regexes specified with raw C<?...?> delimiters may cause mysterious
865errors. The workaround is to use C<m?...?> instead.
866
867Due to the way source filters work in Perl, you can't use Switch inside
868an string C<eval>.
869
870If your source file is longer then 1 million characters and you have a
871switch statement that crosses the 1 million (or 2 million, etc.)
872character boundary you will get mysterious errors. The workaround is to
873use smaller source files.
874
875=head1 COPYRIGHT
876
877    Copyright (c) 1997-2003, Damian Conway. All Rights Reserved.
878    This module is free software. It may be used, redistributed
879        and/or modified under the same terms as Perl itself.
880