]>
Commit | Line | Data |
---|---|---|
6a5fa4e0 MG |
1 | /* |
2 | * tclXlist.c -- | |
3 | * | |
4 | * Extended Tcl list commands. | |
5 | *----------------------------------------------------------------------------- | |
6 | * Copyright 1992 Karl Lehenbauer and Mark Diekhans. | |
7 | * | |
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 | |
13 | * implied warranty. | |
14 | *----------------------------------------------------------------------------- | |
15 | * $Id: tclXlist.c,v 2.0 1992/10/16 04:50:57 markd Rel $ | |
16 | *----------------------------------------------------------------------------- | |
17 | */ | |
18 | ||
19 | #include "tclxint.h" | |
20 | ||
21 | \f | |
22 | /* | |
23 | *----------------------------------------------------------------------------- | |
24 | * | |
25 | * Tcl_LvarcatCmd -- | |
26 | * Implements the TCL lvarpop command: | |
27 | * lvarcat var string string string | |
28 | * | |
29 | * Results: | |
30 | * Standard TCL results. | |
31 | * | |
32 | *----------------------------------------------------------------------------- | |
33 | */ | |
34 | int | |
35 | Tcl_LvarcatCmd (clientData, interp, argc, argv) | |
36 | ClientData clientData; | |
37 | Tcl_Interp *interp; | |
38 | int argc; | |
39 | char **argv; | |
40 | { | |
41 | int listArgc, idx, listIdx; | |
42 | char **listArgv; | |
43 | char *staticArgv [12]; | |
44 | char *varContents, *newStr, *result; | |
45 | ||
46 | if (argc < 3) { | |
47 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], | |
48 | " var string [string...]", (char *) NULL); | |
49 | return TCL_ERROR; | |
50 | } | |
51 | ||
52 | varContents = Tcl_GetVar (interp, argv[1], 0); | |
53 | ||
54 | if (varContents != NULL) | |
55 | listArgc = argc - 1; | |
56 | else | |
57 | listArgc = argc - 2; | |
58 | ||
59 | if (listArgc < (sizeof (staticArgv) / sizeof (char *))) { | |
60 | listArgv = staticArgv; | |
61 | } else { | |
62 | listArgv = (char **) ckalloc (listArgc * sizeof (char *)); | |
63 | } | |
64 | ||
65 | if (varContents != NULL) { | |
66 | listArgv [0] = varContents; | |
67 | listIdx = 1; | |
68 | } else { | |
69 | listIdx = 0; | |
70 | } | |
71 | for (idx = 2; idx < argc; idx++, listIdx++) | |
72 | listArgv [listIdx] = argv [idx]; | |
73 | ||
74 | newStr = Tcl_Concat (listArgc, listArgv); | |
75 | result = Tcl_SetVar (interp, argv [1], newStr, TCL_LEAVE_ERR_MSG); | |
76 | ||
77 | ckfree (newStr); | |
78 | if (listArgv != staticArgv) | |
79 | ckfree ((char *) listArgv); | |
80 | ||
81 | /* | |
82 | * If all is ok, return the variable contents as a "static" result. | |
83 | */ | |
84 | if (result != NULL) { | |
85 | interp->result = result; | |
86 | return TCL_OK; | |
87 | } else { | |
88 | return TCL_ERROR; | |
89 | } | |
90 | } | |
91 | \f | |
92 | /* | |
93 | *----------------------------------------------------------------------------- | |
94 | * | |
95 | * Tcl_LvarpopCmd -- | |
96 | * Implements the TCL lvarpop command: | |
97 | * lvarpop var [index [string]] | |
98 | * | |
99 | * Results: | |
100 | * Standard TCL results. | |
101 | * | |
102 | *----------------------------------------------------------------------------- | |
103 | */ | |
104 | int | |
105 | Tcl_LvarpopCmd (clientData, interp, argc, argv) | |
106 | ClientData clientData; | |
107 | Tcl_Interp *interp; | |
108 | int argc; | |
109 | char **argv; | |
110 | { | |
111 | int listArgc, listIdx, idx; | |
112 | char **listArgv; | |
113 | char *varContents, *resultList, *returnElement; | |
114 | ||
115 | if ((argc < 2) || (argc > 4)) { | |
116 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], | |
117 | " var [index [string]]", (char *) NULL); | |
118 | return TCL_ERROR; | |
119 | } | |
120 | ||
121 | varContents = Tcl_GetVar (interp, argv[1], TCL_LEAVE_ERR_MSG); | |
122 | if (varContents == NULL) | |
123 | return TCL_ERROR; | |
124 | ||
125 | if (Tcl_SplitList (interp, varContents, &listArgc, &listArgv) == TCL_ERROR) | |
126 | return TCL_ERROR; | |
127 | ||
128 | if (argc == 2) | |
129 | listIdx = 0; | |
130 | else { | |
131 | if (Tcl_GetInt (interp, argv[2], &listIdx) != TCL_OK) | |
132 | goto errorExit; | |
133 | } | |
134 | ||
135 | /* | |
136 | * Just ignore out-of bounds requests, like standard Tcl. | |
137 | */ | |
138 | if ((listIdx < 0) || (listIdx >= listArgc)) { | |
139 | goto okExit; | |
140 | } | |
141 | returnElement = listArgv [listIdx]; | |
142 | ||
143 | if (argc == 4) | |
144 | listArgv [listIdx] = argv [3]; | |
145 | else { | |
146 | listArgc--; | |
147 | for (idx = listIdx; idx < listArgc; idx++) | |
148 | listArgv [idx] = listArgv [idx+1]; | |
149 | } | |
150 | ||
151 | resultList = Tcl_Merge (listArgc, listArgv); | |
152 | if (Tcl_SetVar (interp, argv [1], resultList, TCL_LEAVE_ERR_MSG) == NULL) { | |
153 | ckfree (resultList); | |
154 | goto errorExit; | |
155 | } | |
156 | ckfree (resultList); | |
157 | ||
158 | Tcl_SetResult (interp, returnElement, TCL_VOLATILE); | |
159 | okExit: | |
160 | ckfree((char *) listArgv); | |
161 | return TCL_OK; | |
162 | ||
163 | errorExit: | |
164 | ckfree((char *) listArgv); | |
165 | return TCL_ERROR;; | |
166 | } | |
167 | \f | |
168 | /* | |
169 | *----------------------------------------------------------------------------- | |
170 | * | |
171 | * Tcl_LvarpushCmd -- | |
172 | * Implements the TCL lvarpush command: | |
173 | * lvarpush var string [index] | |
174 | * | |
175 | * Results: | |
176 | * Standard TCL results. | |
177 | * | |
178 | *----------------------------------------------------------------------------- | |
179 | */ | |
180 | int | |
181 | Tcl_LvarpushCmd (clientData, interp, argc, argv) | |
182 | ClientData clientData; | |
183 | Tcl_Interp *interp; | |
184 | int argc; | |
185 | char **argv; | |
186 | { | |
187 | int listArgc, listIdx, idx; | |
188 | char **listArgv; | |
189 | char *varContents, *resultList; | |
190 | ||
191 | if ((argc < 3) || (argc > 4)) { | |
192 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], | |
193 | " var string [index]", (char *) NULL); | |
194 | return TCL_ERROR; | |
195 | } | |
196 | ||
197 | varContents = Tcl_GetVar (interp, argv[1], TCL_LEAVE_ERR_MSG); | |
198 | if (varContents == NULL) | |
199 | varContents = ""; | |
200 | ||
201 | if (Tcl_SplitList (interp, varContents, &listArgc, &listArgv) == TCL_ERROR) | |
202 | return TCL_ERROR; | |
203 | ||
204 | if (argc == 3) | |
205 | listIdx = 0; | |
206 | else { | |
207 | if (Tcl_GetInt (interp, argv[3], &listIdx) != TCL_OK) | |
208 | goto errorExit; | |
209 | } | |
210 | ||
211 | /* | |
212 | * Out-of-bounds request go to the start or end, as with most of Tcl. | |
213 | */ | |
214 | if (listIdx < 0) | |
215 | listIdx = 0; | |
216 | else | |
217 | if (listIdx > listArgc) | |
218 | listIdx = listArgc; | |
219 | ||
220 | /* | |
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. | |
223 | */ | |
224 | for (idx = listArgc; idx > listIdx; idx--) | |
225 | listArgv [idx] = listArgv [idx - 1]; | |
226 | ||
227 | listArgv [listIdx] = argv [2]; | |
228 | ||
229 | resultList = Tcl_Merge (listArgc + 1, listArgv); | |
230 | ||
231 | if (Tcl_SetVar (interp, argv [1], resultList, TCL_LEAVE_ERR_MSG) == NULL) { | |
232 | ckfree (resultList); | |
233 | goto errorExit; | |
234 | } | |
235 | ||
236 | ckfree (resultList); | |
237 | ckfree((char *) listArgv); | |
238 | return TCL_OK; | |
239 | ||
240 | errorExit: | |
241 | ckfree((char *) listArgv); | |
242 | return TCL_ERROR;; | |
243 | } | |
244 | \f | |
245 | /* | |
246 | *----------------------------------------------------------------------------- | |
247 | * | |
248 | * Tcl_LemptyCmd -- | |
249 | * Implements the strcat TCL command: | |
250 | * lempty list | |
251 | * | |
252 | * Results: | |
253 | * Standard TCL result. | |
254 | * | |
255 | *----------------------------------------------------------------------------- | |
256 | */ | |
257 | int | |
258 | Tcl_LemptyCmd (clientData, interp, argc, argv) | |
259 | ClientData clientData; | |
260 | Tcl_Interp *interp; | |
261 | int argc; | |
262 | char **argv; | |
263 | { | |
264 | char *scanPtr; | |
265 | ||
266 | if (argc != 2) { | |
267 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " list", | |
268 | (char *) NULL); | |
269 | return TCL_ERROR; | |
270 | } | |
271 | ||
272 | scanPtr = argv [1]; | |
273 | while ((*scanPtr != '\0') && (isspace (*scanPtr))) | |
274 | scanPtr++; | |
275 | sprintf (interp->result, "%d", (*scanPtr == '\0')); | |
276 | return TCL_OK; | |
277 | ||
278 | } /* Tcl_LemptyCmd */ |