git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxlist.c

   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 */