dist/Switch/t/given.t

   1 use Carp;
   2 use Switch qw(Perl6 __ fallthrough);
   3
   4 my($C,$M);sub ok{$C++;$M.=$_[0]?"ok $C\n":"not ok $C (line ".(caller)[2].")\n"}
   5 END{print"1..$C\n$M"}
   6
   7 # NON-when THINGS;
   8
   9 $when->{when} = { when => "when" };
  10
  11 *when = \&when;
  12
  13 # PREMATURE when
  14
  15 eval { when 1 { ok(0) }; ok(0) } || ok(1);
  16
  17 # H.O. FUNCS
  18
  19 given __ > 2 {
  20
  21         when 1  { ok(0) } else { ok(1) }
  22         when 2  { ok(0) } else { ok(1) }
  23         when 3  { ok(1) } else { ok(0) }
  24 }
  25
  26 given (3) {
  27
  28         eval { when __ <= 1 || __ > 2   { ok(0) } } || ok(1);
  29         when __ <= 2            { ok(0) };
  30         when __ <= 3            { ok(1) };
  31 }
  32
  33 # POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE
  34
  35 # 1. NUMERIC SWITCH
  36
  37 for (1..3)
  38 {
  39         given ($_) {
  40                 # SELF
  41                 when ($_) { ok(1) } else { ok(0) }
  42
  43                 # NUMERIC
  44                 when 1 { ok ($_==1) } else { ok($_!=1) }
  45                 when (1)  { ok ($_==1) } else { ok($_!=1) }
  46                 when 3 { ok ($_==3) } else { ok($_!=3) }
  47                 when (4) { ok (0) } else { ok(1) }
  48                 when (2) { ok ($_==2) } else { ok($_!=2) }
  49
  50                 # STRING
  51                 when ('a') { ok (0) } else { ok(1) }
  52                 when  'a'  { ok (0) } else { ok(1) }
  53                 when ('3') { ok ($_ == 3) } else { ok($_ != 3) }
  54                 when ('3.0') { ok (0) } else { ok(1) }
  55
  56                 # ARRAY
  57                 when ([10,5,1]) { ok ($_==1) } else { ok($_!=1) }
  58                 when  [10,5,1]  { ok ($_==1) } else { ok($_!=1) }
  59                 when (['a','b']) { ok (0) } else { ok(1) }
  60                 when (['a','b',3]) { ok ($_==3) } else { ok ($_!=3) }
  61                 when (['a','b',2.0])  { ok ($_==2) } else { ok ($_!=2) }
  62                 when ([])  { ok (0) } else { ok(1) }
  63
  64                 # HASH
  65                 when ({})  { ok (0) } else { ok (1) }
  66                 when {}  { ok (0) } else { ok (1) }
  67                 when {1,1}  { ok ($_==1) } else { ok($_!=1) }
  68                 when ({1=>1, 2=>0})  { ok ($_==1) } else { ok($_!=1) }
  69
  70                 # SUB/BLOCK
  71                 when (sub {$_[0]==2})  { ok ($_==2) } else { ok($_!=2) }
  72                 when {$_[0]==2}  { ok ($_==2) } else { ok($_!=2) }
  73                 when {0}  { ok (0) } else { ok (1) }    # ; -> SUB, NOT HASH
  74                 when {1}  { ok (1) } else { ok (0) }    # ; -> SUB, NOT HASH
  75         }
  76 }
  77
  78
  79 # 2. STRING SWITCH
  80
  81 for ('a'..'c','1')
  82 {
  83         given ($_) {
  84                 # SELF
  85                 when ($_)  { ok(1) } else { ok(0) }
  86
  87                 # NUMERIC
  88                 when (1)   { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
  89                 when (1.0)  { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
  90
  91                 # STRING
  92                 when ('a')  { ok ($_ eq 'a') } else { ok($_ ne 'a') }
  93                 when ('b')  { ok ($_ eq 'b') } else { ok($_ ne 'b') }
  94                 when ('c')  { ok ($_ eq 'c') } else { ok($_ ne 'c') }
  95                 when ('1')  { ok ($_ eq '1') } else { ok($_ ne '1') }
  96                 when ('d')  { ok (0) } else { ok (1) }
  97
  98                 # ARRAY
  99                 when (['a','1'])  { ok ($_ eq 'a' || $_ eq '1') }
 100                         else { ok ($_ ne 'a' && $_ ne '1') }
 101                 when (['z','2'])  { ok (0) } else { ok(1) }
 102                 when ([])  { ok (0) } else { ok(1) }
 103
 104                 # HASH
 105                 when ({})  { ok (0) } else { ok (1) }
 106                 when ({a=>'a', 1=>1, 2=>0})  { ok ($_ eq 'a' || $_ eq '1') }
 107                         else { ok ($_ ne 'a' && $_ ne '1') }
 108
 109                 # SUB/BLOCK
 110                 when (sub{$_[0] eq 'a' })  { ok ($_ eq 'a') }
 111                         else { ok($_ ne 'a') }
 112                 when {$_[0] eq 'a'}  { ok ($_ eq 'a') } else { ok($_ ne 'a') }
 113                 when {0}  { ok (0) } else { ok (1) }    # ; -> SUB, NOT HASH
 114                 when {1}  { ok (1) } else { ok (0) }    # ; -> SUB, NOT HASH
 115         }
 116 }
 117
 118
 119 # 3. ARRAY SWITCH
 120
 121 my $iteration = 0;
 122 for ([],[1,'a'],[2,'b'])
 123 {
 124         given ($_) {
 125         $iteration++;
 126                 # SELF
 127                 when ($_)  { ok(1) }
 128
 129                 # NUMERIC
 130                 when (1)  { ok ($iteration==2) } else { ok ($iteration!=2) }
 131                 when (1.0)  { ok ($iteration==2) } else { ok ($iteration!=2) }
 132
 133                 # STRING
 134                 when ('a')  { ok ($iteration==2) } else { ok ($iteration!=2) }
 135                 when ('b')  { ok ($iteration==3) } else { ok ($iteration!=3) }
 136                 when ('1')  { ok ($iteration==2) } else { ok ($iteration!=2) }
 137
 138                 # ARRAY
 139                 when (['a',2])  { ok ($iteration>=2) } else { ok ($iteration<2) }
 140                 when ([1,'a'])  { ok ($iteration==2) } else { ok($iteration!=2) }
 141                 when ([])  { ok (0) } else { ok(1) }
 142                 when ([7..100])  { ok (0) } else { ok(1) }
 143
 144                 # HASH
 145                 when ({})  { ok (0) } else { ok (1) }
 146                 when ({a=>'a', 1=>1, 2=>0})  { ok ($iteration==2) }
 147                         else { ok ($iteration!=2) }
 148
 149                 # SUB/BLOCK
 150                 when {scalar grep /a/, @_}  { ok ($iteration==2) }
 151                         else { ok ($iteration!=2) }
 152                 when (sub {scalar grep /a/, @_ })  { ok ($iteration==2) }
 153                         else { ok ($iteration!=2) }
 154                 when {0}  { ok (0) } else { ok (1) }    # ; -> SUB, NOT HASH
 155                 when {1}  { ok (1) } else { ok (0) }    # ; -> SUB, NOT HASH
 156         }
 157 }
 158
 159
 160 # 4. HASH SWITCH
 161
 162 $iteration = 0;
 163 for ({},{a=>1,b=>0})
 164 {
 165         given ($_) {
 166         $iteration++;
 167
 168                 # SELF
 169                 when ($_)  { ok(1) } else { ok(0) }
 170
 171                 # NUMERIC
 172                 when (1)  { ok (0) } else { ok (1) }
 173                 when (1.0)  { ok (0) } else { ok (1) }
 174
 175                 # STRING
 176                 when ('a')  { ok ($iteration==2) } else { ok ($iteration!=2) }
 177                 when ('b')  { ok (0) } else { ok (1) }
 178                 when ('c')  { ok (0) } else { ok (1) }
 179
 180                 # ARRAY
 181                 when (['a',2])  { ok ($iteration==2) }
 182                         else { ok ($iteration!=2) }
 183                 when (['b','a'])  { ok ($iteration==2) }
 184                         else { ok ($iteration!=2) }
 185                 when (['b','c'])  { ok (0) } else { ok (1) }
 186                 when ([])  { ok (0) } else { ok(1) }
 187                 when ([7..100])  { ok (0) } else { ok(1) }
 188
 189                 # HASH
 190                 when ({})  { ok (0) } else { ok (1) }
 191                 when ({a=>'a', 1=>1, 2=>0})  { ok (0) } else { ok (1) }
 192
 193                 # SUB/BLOCK
 194                 when {$_[0]{a}}  { ok ($iteration==2) }
 195                         else { ok ($iteration!=2) }
 196                 when (sub {$_[0]{a}})  { ok ($iteration==2) }
 197                         else { ok ($iteration!=2) }
 198                 when {0}  { ok (0) } else { ok (1) }    # ; -> SUB, NOT HASH
 199                 when {1}  { ok (1) } else { ok (0) }    # ; -> SUB, NOT HASH
 200         }
 201 }
 202
 203
 204 # 5. CODE SWITCH
 205
 206 $iteration = 0;
 207 for ( sub {1},
 208       sub { return 0 unless @_;
 209             my ($data) = @_;
 210             my $type = ref $data;
 211             return $type eq 'HASH'   && $data->{a}
 212                 || $type eq 'Regexp' && 'a' =~ /$data/
 213                 || $type eq ""       && $data eq '1';
 214           },
 215       sub {0} )
 216 {
 217         given ($_) {
 218         $iteration++;
 219                 # SELF
 220                 when ($_)  { ok(1) } else { ok(0) }
 221
 222                 # NUMERIC
 223                 when (1)  { ok ($iteration<=2) } else { ok ($iteration>2) }
 224                 when (1.0)  { ok ($iteration<=2) } else { ok ($iteration>2) }
 225                 when (1.1)  { ok ($iteration==1) } else { ok ($iteration!=1) }
 226
 227                 # STRING
 228                 when ('a')  { ok ($iteration==1) } else { ok ($iteration!=1) }
 229                 when ('b')  { ok ($iteration==1) } else { ok ($iteration!=1) }
 230                 when ('c')  { ok ($iteration==1) } else { ok ($iteration!=1) }
 231                 when ('1')  { ok ($iteration<=2) } else { ok ($iteration>2) }
 232
 233                 # ARRAY
 234                 when ([1, 'a'])  { ok ($iteration<=2) }
 235                         else { ok ($iteration>2) }
 236                 when (['b','a'])  { ok ($iteration==1) }
 237                         else { ok ($iteration!=1) }
 238                 when (['b','c'])  { ok ($iteration==1) }
 239                         else { ok ($iteration!=1) }
 240                 when ([])  { ok ($iteration==1) } else { ok($iteration!=1) }
 241                 when ([7..100])  { ok ($iteration==1) }
 242                         else { ok($iteration!=1) }
 243
 244                 # HASH
 245                 when ({})  { ok ($iteration==1) } else { ok ($iteration!=1) }
 246                 when ({a=>'a', 1=>1, 2=>0})  { ok ($iteration<=2) }
 247                         else { ok ($iteration>2) }
 248
 249                 # SUB/BLOCK
 250                 when {$_[0]->{a}}  { ok (0) } else { ok (1) }
 251                 when (sub {$_[0]{a}})  { ok (0) } else { ok (1) }
 252                 when {0}  { ok (0) } else { ok (1) }    # ; -> SUB, NOT HASH
 253                 when {1}  { ok (0) } else { ok (1) }    # ; -> SUB, NOT HASH
 254         }
 255 }
 256
 257
 258 # NESTED SWITCHES
 259
 260 for my $count (1..3)
 261 {
 262         given ([9,"a",11]) {
 263                 when (qr/\d/)  {
 264                                 given ($count) {
 265                                         when (1)      { ok($count==1) }
 266                                                 else { ok($count!=1) }
 267                                         when ([5,6])  { ok(0) } else { ok(1) }
 268                                 }
 269                             }
 270                 ok(1) when 11;
 271         }
 272 }