home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tclX6.5c / src / tclXlist.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-12-19  |  7.2 KB  |  279 lines
  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 "tclExtdInt.h"
  20.  
  21.  
  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.  
  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.  
  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.  
  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 */
  279.