Author: coke
Date: Fri Aug 19 06:35:47 2005
New Revision: 9002
Modified:
trunk/languages/tcl/lib/commands/array.pir
trunk/languages/tcl/t/cmd_array.t
Log:
tcl: implement [array unset]
"It'll add some tests to tcl/t/cmd_array.t, mostly for unset but I added a
get one (feel free to delete, if you think it's unnecessary)
The implementation was added into tcl/lib/commands/array.pir, and I just
added an unset sub."
Courtesy of "Amos Robinson" [#36952]
Modified: trunk/languages/tcl/lib/commands/array.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/array.pir (original)
+++ trunk/languages/tcl/lib/commands/array.pir Fri Aug 19 06:35:47 2005
@@ -290,3 +290,68 @@ not_array:
.return(TCL_ERROR, retval)
.end
+.sub "unset"
+ .param int is_array
+ .param pmc the_array
+ .param string array_name
+ .param pmc argv
+
+ .local int argc
+ argc = argv
+ if argc > 1 goto bad_args
+
+
+ .local string match_str
+ # ?pattern? defaults to matching everything.
+ match_str = "*"
+
+ # if it's there, get it from the arglist
+ if argc == 0 goto no_args
+ match_str = shift argv
+
+no_args:
+ if is_array == 0 goto not_array
+
+ .local pmc retval
+
+ .local pmc iter, val
+ .local string str
+
+ .local pmc globber
+
+ globber = find_global "PGE", "glob"
+ .local pmc rule
+ (rule, $P0, $P1) = globber(match_str)
+
+ iter = new Iterator, the_array
+ iter = .ITERATE_FROM_START
+
+push_loop:
+ unless iter goto push_end
+ str = shift iter
+
+ # check for match
+ $P2 = rule(str)
+ unless $P2 goto push_loop
+
+ delete the_array[str]
+
+ branch push_loop
+push_end:
+
+ retval = new String
+ retval = ""
+ .return (TCL_OK, retval)
+
+
+bad_args:
+ retval = new String
+ retval = "wrong # args: should be \"array unset arrayName ?pattern?\""
+ .return(TCL_ERROR, retval)
+
+not_array:
+ retval = new String
+ retval = ""
+ # is there a better way to do this?
+ .return(TCL_ERROR, retval)
+.end
Modified: trunk/languages/tcl/t/cmd_array.t
==============================================================================
--- trunk/languages/tcl/t/cmd_array.t (original)
+++ trunk/languages/tcl/t/cmd_array.t Fri Aug 19 06:35:47 2005
@@ -2,7 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 25;
+use Parrot::Test tests => 33;
use Test::More;
use vars qw($TODO);
@@ -165,6 +165,13 @@ TCL
apple 1 aardvark 3
OUT
+language_output_is("tcl",<<'TCL',<<'OUT',"array get, with bad pattern");
+ array set a [list apple 1 orange 2 aardvark 3]
+ puts [array get a zippy*]
+TCL
+
+OUT
+
language_output_is("tcl",<<'TCL',<<'OUT',"array get, bad array");
puts [array get a]
TCL
@@ -182,3 +189,57 @@ language_output_is("tcl",<<'TCL',<<'OUT'
TCL
wrong # args: should be "array get arrayName ?pattern?"
OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset");
+ array set a [list a b]
+ puts [array unset a]
+ puts [array get a]
+TCL
+
+
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, with pattern");
+ array set a [list a b c d]
+ puts [array unset a a]
+ puts [array get a]
+TCL
+
+c d
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, with pattern");
+ array set a [list apple 1 orange 2 aardvark 3]
+ puts [array unset a a*]
+ puts [array get a]
+TCL
+
+orange 2
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, with bad pattern");
+ array set a [list apple 1 orange 2 aardvark 3]
+ puts [array unset a zippy*]
+ puts [array get a]
+TCL
+
+apple 1 orange 2 aardvark 3
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, bad array");
+ puts [array unset badarray]
+TCL
+
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, bad array, pattern");
+ puts [array unset badarray monkey*]
+TCL
+
+OUT
+
+language_output_is("tcl", <<'TCL', <<'OUT',"array unset, too many args");
+ array unset monkey my monkey monkey
+TCL
+wrong # args: should be "array unset arrayName ?pattern?"
+OUT
