languages/tcl/t/internals/select_switches.t

   1 #!../../parrot
   2 # Copyright (C) 2001-2008, The Perl Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 languages/tcl/t/internal/select_switches.t
   8
   9 =head1 DESCRIPTION
  10
  11 Excercise select_switches() - this sub handles switch parsing for various
  12 builtins.
  13
  14 =head1 SYNOPSIS
  15
  16  % prove t/internal/select_switches.t
  17
  18 =cut
  19
  20 .HLL 'Tcl', 'tcl_group'
  21 .namespace []
  22
  23 .sub main :main
  24     load_bytecode 'library/Test/More.pir'
  25
  26     # get the testing functions
  27     .local pmc plan, ok, is
  28
  29     plan      = find_global ['Test'; 'More'], 'plan'
  30     ok        = find_global ['Test'; 'More'], 'ok'
  31     is        = find_global ['Test'; 'More'], 'is'
  32
  33     load_bytecode 'languages/tcl/runtime/tcllib.pir'
  34
  35     plan(30)
  36     .local string message
  37
  38     # 1
  39     message = 'does select_switches() exist in _tcl'
  40     .local pmc select_switches
  41     select_switches  = get_root_global ['_tcl'], 'select_switches'
  42     if select_switches goto ok_1
  43 nok_1:
  44     ok(0,message)
  45     end # not much point in doing anything else...
  46 ok_1:
  47     ok(1,message)
  48 done_1:
  49
  50     # Setup options
  51     .local pmc options, argv
  52     options = new 'TclList'
  53     options[0] = 'baz'
  54     options[1] = 'bob'
  55     options[2] = 'joe'
  56
  57     # 2-5
  58     argv = new 'TclList'
  59     argv[0] = '-joe'
  60     argv[1] = 'what'
  61     message='exact match, single, leftover args'
  62     $P1 = select_switches(options, argv)
  63
  64     $I1 = $P1['joe']
  65     $S1 = message . ' (value of switch key)'
  66     is ($I1, 1, $S1)
  67
  68     $I1 = elements $P1
  69     $S1 = message . ' (no other options set)'
  70     is ($I1, 1, $S1)
  71
  72     $I1 = elements argv
  73     $S1 = message . ' (only one argv left)'
  74     is ($I1, 1, $S1)
  75
  76     $S0 = argv[0]
  77     $S1 = message . ' (value of remaining argv)'
  78     is ($S0, 'what', $S1)
  79
  80     # 6-8
  81     argv = new 'TclList'
  82     argv[0] = '-joe'
  83     message='exact match, single, no leftover args'
  84     $P1 = select_switches(options, argv)
  85
  86     $I1 = $P1['joe']
  87     $S1 = message . ' (value of switch key)'
  88     is ($I1, 1, $S1)
  89
  90     $I1 = elements $P1
  91     $S1 = message . ' (no other options set)'
  92     is ($I1, 1, $S1)
  93
  94     $I1 = elements argv
  95     $S1 = message . ' (no args left)'
  96     is ($I1, 0, $S1)
  97
  98     # 9-13
  99     argv = new 'TclList'
 100     argv[0] = '-joe'
 101     argv[1] = '-baz'
 102     argv[2] = 'what'
 103     message='mutliple options, leftover args'
 104     $P1 = select_switches(options, argv)
 105
 106     $I1 = $P1['joe']
 107     $S1 = message . ' (value of -joe key)'
 108     is ($I1, 1, $S1)
 109
 110     $I1 = $P1['baz']
 111     $S1 = message . ' (value of -bar key)'
 112     is ($I1, 1, $S1)
 113
 114     $I1 = elements $P1
 115     $S1 = message . ' (no other options set)'
 116     is ($I1, 2, $S1)
 117
 118     $I1 = elements argv
 119     $S1 = message . ' (only one argv left)'
 120     is ($I1, 1, $S1)
 121
 122     $S0 = argv[0]
 123     $S1 = message . ' (value of remaining argv)'
 124     is ($S0, 'what', $S1)
 125
 126     # 14-17
 127     argv = new 'TclList'
 128     argv[0] = '-joe'
 129     argv[1] = '--'
 130     argv[2] = '-bob'
 131     message='end switch'
 132     $P1 = select_switches(options, argv, 1)
 133
 134     $I1 = $P1['joe']
 135     $S1 = message . ' (value of -joe key)'
 136     is ($I1, 1, $S1)
 137
 138     $I1 = elements $P1
 139     $S1 = message . ' (no other options set)'
 140     is ($I1, 1, $S1)
 141
 142     $I1 = elements argv
 143     $S1 = message . ' (only one argv left)'
 144     is ($I1, 1, $S1)
 145
 146     $S0 = argv[0]
 147     $S1 = message . ' (value of remaining argv)'
 148     is ($S0, '-bob', $S1)
 149
 150     # 18-22
 151     argv = new 'TclList'
 152     argv[0] = '-joke'
 153     argv[1] = 'bag_o_donuts'
 154     message='invalid option specified, no exception'
 155     $P1 = select_switches(options, argv)
 156
 157     $S2 = $P1['joke']
 158     $S1 = message . ' (value of -joke key)'
 159     is ($S2, '', $S1)
 160
 161     $I1 = elements $P1
 162     $S1 = message . ' (no other options set)'
 163     is ($I1, 0, $S1)
 164
 165     $I1 = elements argv
 166     $S1 = message . ' (two args left)'
 167     is ($I1, 2, $S1)
 168
 169     $S0 = argv[0]
 170     $S1 = message . ' (argv[0])'
 171     is ($S0, '-joke', $S1)
 172
 173     $S0 = argv[1]
 174     $S1 = message . ' (argv[1])'
 175     is ($S0, 'bag_o_donuts', $S1)
 176
 177     # 23
 178     argv = new 'TclList'
 179     argv[0] = '-joke'
 180     argv[1] = 'bag_o_donuts'
 181     message='invalid option specified, w/ exception'
 182
 183     push_eh eh_23
 184       $P1 = select_switches(options, argv, 0, 1)
 185     pop_eh
 186
 187     $S2= ''
 188     goto check_23
 189
 190 eh_23:
 191     get_results '0,0', $P2, $S2
 192 check_23:
 193     is($S2, 'bad switch "-joke": must be -baz, -bob, or -joe', message)
 194
 195     # 24
 196     argv = new 'TclList'
 197     argv[0] = '-joke'
 198     argv[1] = 'bag_o_donuts'
 199     message='invalid option specified, w/ exception and --'
 200
 201     push_eh eh_24
 202       $P1 = select_switches(options, argv, 1, 1)
 203     pop_eh
 204
 205     $S2= ''
 206     goto check_24
 207
 208 eh_24:
 209     get_results '0,0', $P2, $S2
 210 check_24:
 211     is($S2, 'bad switch "-joke": must be -baz, -bob, -joe, or --', message)
 212
 213     # 25
 214     argv = new 'TclList'
 215     argv[0] = '-joke'
 216     argv[1] = 'bag_o_donuts'
 217     message='invalid option specified, w/ exception, --, and override name'
 218
 219     push_eh eh_25
 220       $P1 = select_switches(options, argv, 1, 1, 'frob')
 221     pop_eh
 222
 223     $S2= ''
 224     goto check_25
 225
 226 eh_25:
 227     get_results '0,0', $P2, $S2
 228 check_25:
 229     is($S2, 'bad frob "-joke": must be -baz, -bob, -joe, or --', message)
 230
 231     # 26-29
 232     options[2] = 'joe:s' # change this to take a value..
 233
 234     argv = new 'TclList'
 235     argv[0] = '-joe'
 236     argv[1] = 'bag_o_donuts'
 237     argv[2] = 'what'
 238     message='switch with a value specified'
 239     $P1 = select_switches(options, argv)
 240
 241     $S2 = $P1['joe']
 242     $S1 = message . ' (value of -joe key)'
 243     is ($S2, 'bag_o_donuts', $S1)
 244
 245     $I1 = elements $P1
 246     $S1 = message . ' (no other options set)'
 247     is ($I1, 1, $S1)
 248
 249     $I1 = elements argv
 250     $S1 = message . ' (only one argv left)'
 251     is ($I1, 1, $S1)
 252
 253     $S0 = argv[0]
 254     $S1 = message . ' (value of remaining argv)'
 255     is ($S0, 'what', $S1)
 256
 257     # 30
 258     options = new 'TclList'
 259     options[0] = 'good0'
 260     options[1] = 'good1'
 261
 262     argv = new 'TclList'
 263     argv[0] = '-fail'
 264     argv[1] = 'bag_o_donuts'
 265     message='invalid option specified, with choice of 2, w/ exception'
 266
 267     push_eh eh_30
 268       $P1 = select_switches(options, argv, 0, 1)
 269     pop_eh
 270
 271     $S2= ''
 272     goto check_30
 273
 274 eh_30:
 275     get_results '0,0', $P2, $S2
 276 check_30:
 277     is($S2, 'bad switch "-fail": must be -good0 or -good1', message)
 278
 279 .end
 280
 281 # Local Variables:
 282 #   mode: pir
 283 #   fill-column: 100
 284 # End:
 285 # vim: expandtab shiftwidth=4 ft=pir: