]>
git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxlist.c
4 * Extended Tcl list commands.
5 *-----------------------------------------------------------------------------
6 * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
8 * Permission to use, copy, modify, and distribute this software and its
9 * documentation for any purpose and without fee is hereby granted, provided
10 * that the above copyright notice appear in all copies. Karl Lehenbauer and
11 * Mark Diekhans make no representations about the suitability of this
12 * software for any purpose. It is provided "as is" without express or
14 *-----------------------------------------------------------------------------
15 * $Id: tclXlist.c,v 2.0 1992/10/16 04:50:57 markd Rel $
16 *-----------------------------------------------------------------------------
23 *-----------------------------------------------------------------------------
26 * Implements the TCL lvarpop command:
27 * lvarcat var string string string
30 * Standard TCL results.
32 *-----------------------------------------------------------------------------
35 Tcl_LvarcatCmd (clientData
, interp
, argc
, argv
)
36 ClientData clientData
;
41 int listArgc
, idx
, listIdx
;
43 char *staticArgv
[12];
44 char *varContents
, *newStr
, *result
;
47 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
48 " var string [string...]", (char *) NULL
);
52 varContents
= Tcl_GetVar (interp
, argv
[1], 0);
54 if (varContents
!= NULL
)
59 if (listArgc
< (sizeof (staticArgv
) / sizeof (char *))) {
60 listArgv
= staticArgv
;
62 listArgv
= (char **) ckalloc (listArgc
* sizeof (char *));
65 if (varContents
!= NULL
) {
66 listArgv
[0] = varContents
;
71 for (idx
= 2; idx
< argc
; idx
++, listIdx
++)
72 listArgv
[listIdx
] = argv
[idx
];
74 newStr
= Tcl_Concat (listArgc
, listArgv
);
75 result
= Tcl_SetVar (interp
, argv
[1], newStr
, TCL_LEAVE_ERR_MSG
);
78 if (listArgv
!= staticArgv
)
79 ckfree ((char *) listArgv
);
82 * If all is ok, return the variable contents as a "static" result.
85 interp
->result
= result
;
93 *-----------------------------------------------------------------------------
96 * Implements the TCL lvarpop command:
97 * lvarpop var [index [string]]
100 * Standard TCL results.
102 *-----------------------------------------------------------------------------
105 Tcl_LvarpopCmd (clientData
, interp
, argc
, argv
)
106 ClientData clientData
;
111 int listArgc
, listIdx
, idx
;
113 char *varContents
, *resultList
, *returnElement
;
115 if ((argc
< 2) || (argc
> 4)) {
116 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
117 " var [index [string]]", (char *) NULL
);
121 varContents
= Tcl_GetVar (interp
, argv
[1], TCL_LEAVE_ERR_MSG
);
122 if (varContents
== NULL
)
125 if (Tcl_SplitList (interp
, varContents
, &listArgc
, &listArgv
) == TCL_ERROR
)
131 if (Tcl_GetInt (interp
, argv
[2], &listIdx
) != TCL_OK
)
136 * Just ignore out-of bounds requests, like standard Tcl.
138 if ((listIdx
< 0) || (listIdx
>= listArgc
)) {
141 returnElement
= listArgv
[listIdx
];
144 listArgv
[listIdx
] = argv
[3];
147 for (idx
= listIdx
; idx
< listArgc
; idx
++)
148 listArgv
[idx
] = listArgv
[idx
+1];
151 resultList
= Tcl_Merge (listArgc
, listArgv
);
152 if (Tcl_SetVar (interp
, argv
[1], resultList
, TCL_LEAVE_ERR_MSG
) == NULL
) {
158 Tcl_SetResult (interp
, returnElement
, TCL_VOLATILE
);
160 ckfree((char *) listArgv
);
164 ckfree((char *) listArgv
);
169 *-----------------------------------------------------------------------------
172 * Implements the TCL lvarpush command:
173 * lvarpush var string [index]
176 * Standard TCL results.
178 *-----------------------------------------------------------------------------
181 Tcl_LvarpushCmd (clientData
, interp
, argc
, argv
)
182 ClientData clientData
;
187 int listArgc
, listIdx
, idx
;
189 char *varContents
, *resultList
;
191 if ((argc
< 3) || (argc
> 4)) {
192 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
193 " var string [index]", (char *) NULL
);
197 varContents
= Tcl_GetVar (interp
, argv
[1], TCL_LEAVE_ERR_MSG
);
198 if (varContents
== NULL
)
201 if (Tcl_SplitList (interp
, varContents
, &listArgc
, &listArgv
) == TCL_ERROR
)
207 if (Tcl_GetInt (interp
, argv
[3], &listIdx
) != TCL_OK
)
212 * Out-of-bounds request go to the start or end, as with most of Tcl.
217 if (listIdx
> listArgc
)
221 * This code takes advantage of the fact that a NULL entry is always
222 * returned by Tcl_SplitList, but not required by Tcl_Merge.
224 for (idx
= listArgc
; idx
> listIdx
; idx
--)
225 listArgv
[idx
] = listArgv
[idx
- 1];
227 listArgv
[listIdx
] = argv
[2];
229 resultList
= Tcl_Merge (listArgc
+ 1, listArgv
);
231 if (Tcl_SetVar (interp
, argv
[1], resultList
, TCL_LEAVE_ERR_MSG
) == NULL
) {
237 ckfree((char *) listArgv
);
241 ckfree((char *) listArgv
);
246 *-----------------------------------------------------------------------------
249 * Implements the strcat TCL command:
253 * Standard TCL result.
255 *-----------------------------------------------------------------------------
258 Tcl_LemptyCmd (clientData
, interp
, argc
, argv
)
259 ClientData clientData
;
267 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], " list",
273 while ((*scanPtr
!= '\0') && (isspace (*scanPtr
)))
275 sprintf (interp
->result
, "%d", (*scanPtr
== '\0'));
278 } /* Tcl_LemptyCmd */