Basic implementation of TIP#57 - TclX's [lassign] command into Tcl core

Not a direct copy
  * Better use of Tcl object API
  * More extensive test suite
  * More extensive documentation

6 files changed, 249 insertions, 4 deletions

diff --git a/ChangeLog b/ChangeLog
index dafe1db..b248a1f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2004-01-17  Donal K. Fellows  <dkf@users.sf.net>
+
+	BASIC IMPLEMENTATION OF TIP#57
+	* generic/tclCmdIL.c (Tcl_LassignObjCmd): Implementation of the
+	[lassign] command that takes full advantage of Tcl's object API.
+	* doc/lassign.n: New file documenting the command.
+	* tests/cmdIL.test (cmdIL-6.*): Test suite for the command.
+
 2004-01-15  David Gravereaux <davygrvy@pobox.com>
 
 	* win/tclWinReg.c:  Placed the requirement for advapi.lib into
diff --git a/doc/lassign.n b/doc/lassign.n
new file mode 100644
index 0000000..f27422d
--- /dev/null
+++ b/doc/lassign.n
@@ -0,0 +1,55 @@
+'\"
+'\" Copyright (c) 1992-1999 Karl Lehenbauer & Mark Diekhans
+'\" Copyright (c) 2004 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\" 
+'\" RCS: @(#) $Id: lassign.n,v 1.1 2004/01/17 00:28:08 dkf Exp $
+'\" 
+.so man.macros
+.TH lassign n 8.5 Tcl "Tcl Built-In Commands"
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+lassign \- Assign list elements to variables
+.SH SYNOPSIS
+\fBlassign \fIlist varName \fR?\fIvarName ...\fR?
+.BE
+
+.SH DESCRIPTION
+.PP
+This command treats the value \fIlist\fR as a list and assigns
+successive elements from that list to the variables given by the
+\fIvarName\fR arguments in order.  If there are more variable names
+than list elements, the remaining variables are set to the empty
+string.  If there are more list elements than variables, a list of
+unassigned elements is returned.
+.SH EXAMPLES
+An illustration of how multiple assignment works, and what happens
+when there are either too few or too many elements.
+.CS
+lassign {a b c} x y z       ;# Empty return
+puts $x                     ;# Prints "a"
+puts $y                     ;# Prints "b"
+puts $z                     ;# Prints "c"
+
+lassign {d e} x y z         ;# Empty return
+puts $x                     ;# Prints "d"
+puts $y                     ;# Prints "e"
+puts $z                     ;# Prints ""
+
+lassign {f g h i} x y       ;# Returns "h i"
+puts $x                     ;# Prints "f"
+puts $y                     ;# Prints "g"
+.CE
+The \fBlassign\fR command has other uses.  It can be used to create
+the analogue of the "shift" command in many shell languages like this:
+.CS
+set ::argv [lassign $::argv argumentToReadOff]
+.CE
+.SH "SEE ALSO"
+lindex(n), list(n), lset(n), set(n)
+
+.SH KEYWORDS
+assign, element, list, multiple, set, variable
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d601396..09fe3e6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.94 2003/12/24 04:18:18 davygrvy Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.95 2004/01/17 00:28:08 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -114,6 +114,8 @@ static CmdInfo builtInCmds[] = {
         (CompileProc *) NULL,		1},
     {"lappend",		(Tcl_CmdProc *) NULL,	Tcl_LappendObjCmd,
         TclCompileLappendCmd,		1},
+    {"lassign",		(Tcl_CmdProc *) NULL,	Tcl_LassignObjCmd,
+        (CompileProc *) NULL,		1},
     {"lindex",		(Tcl_CmdProc *) NULL,	Tcl_LindexObjCmd,
         TclCompileLindexCmd,		1},
     {"linsert",		(Tcl_CmdProc *) NULL,	Tcl_LinsertObjCmd,
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 0b8de0d..e570d56 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdIL.c,v 1.58 2003/12/24 04:18:18 davygrvy Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.59 2004/01/17 00:28:08 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -2024,6 +2024,102 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv)
 /*
  *----------------------------------------------------------------------
  *
+ * Tcl_LassignObjCmd --
+ *
+ *	This object-based procedure is invoked to process the "lassign" Tcl
+ *	command. See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+    /* ARGSUSED */
+int
+Tcl_LassignObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    Tcl_Obj *valueObj;		/* Value to assign to variable, as read from
+				 * the list object or created in the emptyObj
+				 * variable. */
+    Tcl_Obj *emptyObj = NULL;	/* If non-NULL, an empty object created for
+				 * being assigned to variables once we have
+				 * run out of values from the list object. */
+    Tcl_Obj **listObjv;		/* The contents of the list. */
+    int listObjc;		/* The length of the list. */
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "list varname ?varname ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * First assign values out of the list to variables.
+     */
+
+    for (i=0 ; i+2<objc ; i++) {
+	/*
+	 * We do this each time round the loop because that is robust
+	 * against shimmering nasties.
+	 */
+	if (Tcl_ListObjIndex(interp, objv[1], i, &valueObj) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (valueObj == NULL) {
+	    if (emptyObj == NULL) {
+		TclNewObj(emptyObj);
+		Tcl_IncrRefCount(emptyObj);
+	    }
+	    valueObj = emptyObj;
+	}
+	if (Tcl_ObjSetVar2(interp, objv[i+2], NULL, valueObj,
+		TCL_LEAVE_ERR_MSG) == NULL) {
+	    if (emptyObj != NULL) {
+		Tcl_DecrRefCount(emptyObj);
+	    }
+	    return TCL_ERROR;
+	}
+    }
+    if (emptyObj != NULL) {
+	Tcl_DecrRefCount(emptyObj);
+    }
+
+    /*
+     * Now place a list of any values left over into the interpreter
+     * result.
+     *
+     * First, figure out how many values were not assigned by getting
+     * the length of the list.  Note that I do not expect this
+     * operation to fail.
+     */
+
+    if (Tcl_ListObjGetElements(interp, objv[1],
+	    &listObjc, &listObjv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    if (listObjc > objc-2) {
+	/*
+	 * OK, there were left-overs.  Make a list of them and slap
+	 * that back in the interpreter result.
+	 */
+	Tcl_SetObjResult(interp,
+		Tcl_NewListObj(listObjc - objc + 2, listObjv + objc - 2));
+    }
+
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_LindexObjCmd --
  *
  *	This object-based procedure is invoked to process the "lindex" Tcl
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6423e4f..3c4b7b7 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.140 2004/01/13 23:15:03 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.141 2004/01/17 00:28:08 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -1910,6 +1910,8 @@ EXTERN int	Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int	Tcl_LassignObjCmd _ANSI_ARGS_((ClientData clientData,
+		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_LindexObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_LinsertObjCmd _ANSI_ARGS_((ClientData clientData,
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index e008dfd..94dd24f 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -8,13 +8,16 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: cmdIL.test,v 1.18 2003/11/10 18:30:41 dkf Exp $
+# RCS: @(#) $Id: cmdIL.test,v 1.19 2004/01/17 00:28:08 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
     namespace import -force ::tcltest::*
 }
 
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+
 test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
     list [catch {lsort} msg] $msg
 } {1 {wrong # args: should be "lsort ?options? list"}}
@@ -417,6 +420,85 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body {
     rename test_lsort ""
 }
 
+test cmdIL-6.1 {lassign command syntax} -body {
+    lassign
+} -code 1 -result {wrong # args: should be "lassign list varname ?varname ...?"}
+test cmdIL-6.2 {lassign command syntax} -body {
+    lassign x
+} -code 1 -result {wrong # args: should be "lassign list varname ?varname ...?"}
+test cmdIL-6.3 {lassign command} {
+    set x FAIL
+    list [lassign a x] $x
+} {{} a}
+test cmdIL-6.4 {lassign command} {
+    set x FAIL
+    set y FAIL
+    list [lassign a x y] $x $y
+} {{} a {}}
+test cmdIL-6.5 {lassign command} {
+    set x FAIL
+    set y FAIL
+    list [lassign {a b} x y] $x $y
+} {{} a b}
+test cmdIL-6.6 {lassign command} {
+    set x FAIL
+    set y FAIL
+    list [lassign {a b c} x y] $x $y
+} {c a b}
+test cmdIL-6.7 {lassign command} {
+    set x FAIL
+    set y FAIL
+    list [lassign {a b c d} x y] $x $y
+} {{c d} a b}
+test cmdIL-6.8 {lassign command - list format error} {
+    set x FAIL
+    set y FAIL
+    list [catch {lassign {a {b}c d} x y} msg] $msg $x $y
+} {1 {list element in braces followed by "c" instead of space} FAIL FAIL}
+catch {unset x y}
+test cmdIL-6.9 {lassign command - assignment to arrays} {
+    list [lassign {a b} x(x)] $x(x)
+} {b a}
+test cmdIL-6.10 {lassign command - variable update error} -body {
+    set x(x) {}
+    lassign a x
+} -code 1 -result {can't set "x": variable is array} -cleanup {
+    unset x
+}
+test cmdIL-6.11 {lassign command - variable update error} -body {
+    set x(x) {}
+    set y FAIL
+    list [catch {lassign a y x} msg] $msg $y
+} -result {1 {can't set "x": variable is array} a} -cleanup {
+    unset x
+}
+test cmdIL-6.12 {lassign command - memory leak testing} -setup {
+    set x(x) {}
+    set y FAIL
+    proc getbytes {} {
+        set lines [split [memory info] "\n"]
+        lindex [lindex $lines 3] 3
+    }
+    proc stress {} {
+	global x y
+	lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y y y y y y
+	catch {lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y x}
+	catch {lassign {} x}
+    }
+} -constraints memory -body {
+    set end [getbytes]
+    for {set i 0} {$i < 5} {incr i} {
+	stress
+	set tmp $end
+	set end [getbytes]
+    }
+    expr {$end - $tmp}
+} -result 0 -cleanup {
+    unset -nocomplain x y i tmp end
+    rename getbytes {}
+    rename stress {}
+}
+
 # cleanup
 ::tcltest::cleanupTests
 return