home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / src / tclXstring.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-26  |  14.8 KB  |  557 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCLExtend
  3. #endif
  4. /* 
  5.  * tclXstring.c --
  6.  *
  7.  *      Extended TCL string and character manipulation commands.
  8.  *-----------------------------------------------------------------------------
  9.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  10.  *
  11.  * Permission to use, copy, modify, and distribute this software and its
  12.  * documentation for any purpose and without fee is hereby granted, provided
  13.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  14.  * Mark Diekhans make no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without express or
  16.  * implied warranty.
  17.  *-----------------------------------------------------------------------------
  18.  * $Id: tclXstring.c,v 2.8 1993/08/31 23:24:52 markd Exp $
  19.  *-----------------------------------------------------------------------------
  20.  */
  21.  
  22. #include "tclExtdInt.h"
  23.  
  24. /*
  25.  * Prototypes of internal functions.
  26.  */
  27. static unsigned int
  28. ExpandString _ANSI_ARGS_((unsigned char *s,
  29.                           unsigned char  buf[]));
  30.  
  31.  
  32. /*
  33.  *-----------------------------------------------------------------------------
  34.  *
  35.  * Tcl_CindexCmd --
  36.  *     Implements the cindex TCL command:
  37.  *         cindex string indexExpr
  38.  *
  39.  * Results:
  40.  *      Returns the character indexed by  index  (zero  based)  from
  41.  *      string. 
  42.  *
  43.  *-----------------------------------------------------------------------------
  44.  */
  45. int
  46. Tcl_CindexCmd (clientData, interp, argc, argv)
  47.     ClientData   clientData;
  48.     Tcl_Interp  *interp;
  49.     int          argc;
  50.     char       **argv;
  51. {
  52.     long index, len;
  53.  
  54.     if (argc != 3) {
  55.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  56.                           " string indexExpr", (char *) NULL);
  57.         return TCL_ERROR;
  58.     }
  59.     
  60.     len = strlen (argv [1]);
  61.     if (Tcl_RelativeExpr (interp, argv[2], len, &index) != TCL_OK)
  62.         return TCL_ERROR;
  63.     if (index >= len)
  64.         return TCL_OK;
  65.  
  66.     interp->result [0] = argv[1][index];
  67.     interp->result [1] = 0;
  68.     return TCL_OK;
  69.  
  70. }
  71.  
  72. /*
  73.  *-----------------------------------------------------------------------------
  74.  *
  75.  * Tcl_ClengthCmd --
  76.  *     Implements the clength TCL command:
  77.  *         clength string
  78.  *
  79.  * Results:
  80.  *      Returns the length of string in characters. 
  81.  *
  82.  *-----------------------------------------------------------------------------
  83.  */
  84. int
  85. Tcl_ClengthCmd (clientData, interp, argc, argv)
  86.     ClientData   clientData;
  87.     Tcl_Interp  *interp;
  88.     int          argc;
  89.     char       **argv;
  90. {
  91.  
  92.     if (argc != 2) {
  93.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " string", 
  94.                           (char *) NULL);
  95.         return TCL_ERROR;
  96.     }
  97.  
  98.     sprintf (interp->result, "%d", strlen (argv[1]));
  99.     return TCL_OK;
  100.  
  101. }
  102.  
  103. /*
  104.  *-----------------------------------------------------------------------------
  105.  *
  106.  * Tcl_CrangeCmd --
  107.  *     Implements the crange and csubstr TCL commands:
  108.  *         crange string firstExpr lastExpr
  109.  *         csubstr string firstExpr lengthExpr
  110.  *
  111.  * Results:
  112.  *      Standard Tcl result.
  113.  *-----------------------------------------------------------------------------
  114.  */
  115. int
  116. Tcl_CrangeCmd (clientData, interp, argc, argv)
  117.     ClientData   clientData;
  118.     Tcl_Interp  *interp;
  119.     int          argc;
  120.     char       **argv;
  121. {
  122.     long      fullLen, first;
  123.     long      subLen;
  124.     char     *strPtr;
  125.     char      holdChar;
  126.     int       isRange = (argv [0][1] == 'r');  /* csubstr or crange */
  127.  
  128.     if (argc != 4) {
  129.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  130.                           " string firstExpr ", 
  131.                           (isRange) ? "lastExpr" : "lengthExpr",
  132.                           (char *) NULL);
  133.         return TCL_ERROR;
  134.     }
  135.  
  136.     fullLen = strlen (argv [1]);
  137.  
  138.     if (Tcl_RelativeExpr (interp, argv[2], fullLen, &first) != TCL_OK)
  139.         return TCL_ERROR;
  140.  
  141.     if (first >= fullLen)
  142.         return TCL_OK;
  143.  
  144.     if (Tcl_RelativeExpr (interp, argv[3], fullLen, &subLen) != TCL_OK)
  145.         return TCL_ERROR;
  146.         
  147.     if (isRange) {
  148.         if (subLen < first) {
  149.             Tcl_AppendResult (interp, "last is before first",
  150.                               (char *) NULL);
  151.             return TCL_ERROR;
  152.         }
  153.         subLen = subLen - first +1;
  154.     }
  155.  
  156.     if (first + subLen > fullLen)
  157.         subLen = fullLen - first;
  158.  
  159.     strPtr = argv [1] + first;
  160.  
  161.     holdChar = strPtr [subLen];
  162.     strPtr [subLen] = '\0';
  163.     Tcl_SetResult (interp, strPtr, TCL_VOLATILE);
  164.     strPtr [subLen] = holdChar;
  165.  
  166.     return TCL_OK;
  167. }
  168.  
  169. /*
  170.  *-----------------------------------------------------------------------------
  171.  *
  172.  * Tcl_ReplicateCmd --
  173.  *     Implements the replicate TCL command:
  174.  *         replicate string countExpr
  175.  *
  176.  * Results:
  177.  *      Returns string replicated count times.
  178.  *
  179.  *-----------------------------------------------------------------------------
  180.  */
  181. int
  182. Tcl_ReplicateCmd (clientData, interp, argc, argv)
  183.     ClientData   clientData;
  184.     Tcl_Interp  *interp;
  185.     int          argc;
  186.     char       **argv;
  187. {
  188.     long           repCount;
  189.     register char *srcPtr, *scanPtr, *newPtr;
  190.     register long  newLen, cnt;
  191.  
  192.     if (argc != 3) {
  193.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  194.                           " string countExpr", (char *) NULL);
  195.         return TCL_ERROR;
  196.     }
  197.  
  198.     if (Tcl_ExprLong (interp, argv[2], &repCount) != TCL_OK)
  199.         return TCL_ERROR;
  200.  
  201.     srcPtr = argv [1];
  202.     newLen = strlen (srcPtr) * repCount;
  203.     if (newLen >= TCL_RESULT_SIZE)
  204.         Tcl_SetResult (interp, ckalloc ((unsigned) newLen + 1), TCL_DYNAMIC);
  205.  
  206.     newPtr = interp->result;
  207.     for (cnt = 0; cnt < repCount; cnt++) {
  208.         for (scanPtr = srcPtr; *scanPtr != 0; scanPtr++)
  209.             *newPtr++ = *scanPtr;
  210.     }
  211.     *newPtr = 0;
  212.  
  213.     return TCL_OK;
  214.  
  215. }
  216.  
  217. /*
  218.  *-----------------------------------------------------------------------------
  219.  *
  220.  * Tcl_CtokenCmd --
  221.  *     Implements the clength TCL command:
  222.  *         ctoken strvar separators
  223.  *
  224.  * Results:
  225.  *      Returns the first token and removes it from the string variable.
  226.  *
  227.  *-----------------------------------------------------------------------------
  228.  */
  229. int
  230. Tcl_CtokenCmd (clientData, interp, argc, argv)
  231.     ClientData   clientData;
  232.     Tcl_Interp  *interp;
  233.     int          argc;
  234.     char       **argv;
  235. {
  236.     Tcl_DString  string;
  237.     char        *varValue, *startPtr;
  238.     int          tokenLen;
  239.  
  240.     if (argc != 3) {
  241.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  242.                           " strvar separators", (char *) NULL);
  243.         return TCL_ERROR;
  244.     }
  245.     
  246.     varValue = Tcl_GetVar (interp, argv [1], TCL_LEAVE_ERR_MSG);
  247.     if (varValue == NULL)
  248.         return TCL_ERROR;
  249.  
  250.     Tcl_DStringInit (&string);
  251.     Tcl_DStringAppend (&string, varValue, -1);
  252.  
  253.     startPtr = string.string + strspn (string.string, argv [2]);
  254.     tokenLen = strcspn (startPtr, argv [2]);
  255.  
  256.     if (Tcl_SetVar (interp, argv [1], startPtr + tokenLen,
  257.                     TCL_LEAVE_ERR_MSG) == NULL) {
  258.         Tcl_DStringFree (&string);
  259.         return TCL_ERROR;
  260.     }
  261.     startPtr [tokenLen] = '\0';
  262.     Tcl_SetResult (interp, startPtr, TCL_VOLATILE);
  263.     Tcl_DStringFree (&string);
  264.  
  265.     return TCL_OK;
  266. }
  267.  
  268. /*
  269.  *-----------------------------------------------------------------------------
  270.  *
  271.  * ExpandString --
  272.  *  Build an expand version of a translit range specification.
  273.  *
  274.  * Results:
  275.  *  TRUE it the expansion is ok, FALSE it its too long.
  276.  *
  277.  *-----------------------------------------------------------------------------
  278.  */
  279. #define MAX_EXPANSION 255
  280.  
  281. static unsigned int
  282. ExpandString (s, buf)
  283.     unsigned char *s;
  284.     unsigned char  buf[];
  285. {
  286.     int i, j;
  287.  
  288.     i = 0;
  289.     while((*s !=0) && i < MAX_EXPANSION) {
  290.         if(s[1] == '-' && s[2] > s[0]) {
  291.             for(j = s[0]; j <= s[2]; j++)
  292.                 buf[i++] = j;
  293.             s += 3;
  294.         } else
  295.             buf[i++] = *s++;
  296.     }
  297.     buf[i] = 0;
  298.     return (i < MAX_EXPANSION);
  299. }
  300.  
  301. /*
  302.  *-----------------------------------------------------------------------------
  303.  *
  304.  * Tcl_TranslitCmd --
  305.  *     Implements the TCL translit command:
  306.  *     translit inrange outrange string
  307.  *
  308.  * Results:
  309.  *  Standard TCL results.
  310.  *
  311.  *-----------------------------------------------------------------------------
  312.  */
  313. int
  314. Tcl_TranslitCmd (clientData, interp, argc, argv)
  315.     ClientData   clientData;
  316.     Tcl_Interp  *interp;
  317.     int          argc;
  318.     char       **argv;
  319. {
  320.     unsigned char from [MAX_EXPANSION+1];
  321.     unsigned char to   [MAX_EXPANSION+1];
  322.     unsigned char map  [MAX_EXPANSION+1];
  323.     unsigned char *s, *t;
  324.     int idx;
  325.  
  326.     if (argc != 4) {
  327.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  328.                           " from to string", (char *) NULL);
  329.         return TCL_ERROR;
  330.     }
  331.  
  332.     if (!ExpandString ((unsigned char *) argv[1], from)) {
  333.         interp->result = "inrange expansion too long";
  334.         return TCL_ERROR;
  335.     }
  336.  
  337.     if (!ExpandString ((unsigned char *) argv[2], to)) {
  338.         interp->result = "outrange expansion too long";
  339.         return TCL_ERROR;
  340.     }
  341.  
  342.     for (idx = 0; idx <= MAX_EXPANSION; idx++)
  343.         map [idx] = idx;
  344.  
  345.     for (idx = 0; to [idx] != '\0'; idx++) {
  346.         if (from [idx] != '\0')
  347.             map [from [idx]] = to [idx];
  348.         else
  349.             break;
  350.     }
  351.     if (to [idx] != '\0') {
  352.         interp->result = "inrange longer than outrange";
  353.         return TCL_ERROR;
  354.     }
  355.  
  356.     for (; from [idx] != '\0'; idx++)
  357.         map [from [idx]] = 0;
  358.  
  359.     for (s = t = (unsigned char *) argv[3]; *s != '\0'; s++) {
  360.         if (map[*s] != '\0')
  361.             *t++ = map [*s];
  362.     }
  363.     *t = '\0';
  364.  
  365.     Tcl_SetResult (interp, argv[3], TCL_VOLATILE);
  366.  
  367.     return TCL_OK;
  368. }
  369.  
  370. /*
  371.  *-----------------------------------------------------------------------------
  372.  *
  373.  * Tcl_CtypeCmd --
  374.  *
  375.  *      This function implements the 'ctype' command:
  376.  *      ctype class string
  377.  *
  378.  *      Where class is one of the following:
  379.  *        digit, xdigit, lower, upper, alpha, alnum,
  380.  *        space, cntrl,  punct, print, graph, ascii, char or ord.
  381.  *
  382.  * Results:
  383.  *       One or zero: Depending if all the characters in the string are of
  384.  *       the desired class.  Char and ord provide conversions and return the
  385.  *       converted value.
  386.  *
  387.  *-----------------------------------------------------------------------------
  388.  */
  389.  
  390. #ifdef THINK_C
  391. #define isascii(c)        ((unsigned char)(c)<=0177)
  392. #endif
  393.  
  394. int
  395. Tcl_CtypeCmd (clientData, interp, argc, argv)
  396.     ClientData   clientData;
  397.     Tcl_Interp  *interp;
  398.     int          argc;
  399.     char       **argv;
  400. {
  401.     register char *class;
  402.     register char *scanPtr = argv [2];
  403.  
  404.     if (argc != 3) {
  405.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " class string",
  406.                           (char *) NULL);
  407.         return TCL_ERROR;
  408.     }
  409.  
  410.     class = argv [1];
  411.  
  412.     /*
  413.      * Handle conversion requests.
  414.      */
  415.     if (STREQU (class, "char")) {
  416.         int number;
  417.  
  418.         if (Tcl_GetInt (interp, argv [2], &number) != TCL_OK)
  419.             return TCL_ERROR;
  420.         if ((number < 0) || (number > 255)) {
  421.             Tcl_AppendResult (interp, "number must be in the range 0..255",
  422.                               (char *) NULL);
  423.             return TCL_ERROR;
  424.         }
  425.  
  426.         interp->result [0] = number;
  427.         interp->result [1] = 0;
  428.         return TCL_OK;
  429.     }
  430.  
  431.     if (STREQU (class, "ord")) {
  432.         int value;
  433.  
  434.         if ((argv [2][0] == '\0') || (argv [2][1] != '\0')) {
  435.             Tcl_AppendResult (interp, "string to convert must be only one",
  436.                               " character", (char *) NULL);
  437.             return TCL_ERROR;
  438.         }
  439.         
  440.         value = 0xff & argv [2][0];  /* Prevent sign extension */
  441.         sprintf (interp->result, "%u", value);
  442.         return TCL_OK;
  443.     }
  444.  
  445.     /*
  446.      * Select based on the first letter of the 'class' argument to chose the 
  447.      * macro to test characters with.  In some cases another character must be
  448.      * switched on to determine which macro to use.  This is gross, but better
  449.      * we only have to do a string compare once to test if class is correct.
  450.      */
  451.     if ((class [2] == 'n') && STREQU (class, "alnum")) {
  452.         for (; *scanPtr != 0; scanPtr++) {
  453.             if (!isalnum (UCHAR (*scanPtr)))
  454.                 break;
  455.         }
  456.         goto returnResult;
  457.     }
  458.     if ((class [2] == 'p') && STREQU (class, "alpha")) {
  459.         for (; *scanPtr != 0; scanPtr++) {
  460.             if (!isalpha (UCHAR (*scanPtr)))
  461.                 break;
  462.         }
  463.         goto returnResult;
  464.     }
  465.     if ((class [1] == 's') && STREQU (class, "ascii")) {
  466.         for (; *scanPtr != 0; scanPtr++) {
  467.             if (!isascii (UCHAR (*scanPtr)))
  468.                 break;
  469.         }
  470.         goto returnResult;
  471.     }
  472.     if (STREQU (class, "cntrl")) {
  473.         for (; *scanPtr != 0; scanPtr++) {
  474.             if (!iscntrl (UCHAR (*scanPtr)))
  475.                 break;
  476.         }
  477.         goto returnResult;
  478.     }
  479.     if (STREQU (class, "digit")) {
  480.         for (; *scanPtr != 0; scanPtr++) {
  481.             if (!isdigit (UCHAR (*scanPtr)))
  482.                 break;
  483.         }
  484.         goto returnResult;
  485.     }
  486.     if (STREQU (class, "graph")) {
  487.         for (; *scanPtr != 0; scanPtr++) {
  488.             if (!isgraph (UCHAR (*scanPtr)))
  489.                 break;
  490.         }
  491.         goto returnResult;
  492.     }
  493.     if (STREQU (class, "lower")) {
  494.         for (; *scanPtr != 0; scanPtr++) {
  495.             if (!islower (UCHAR (*scanPtr)))
  496.                 break;
  497.         }
  498.         goto returnResult;
  499.     }
  500.     if ((class [1] == 'r') && STREQU (class, "print")) {
  501.         for (; *scanPtr != 0; scanPtr++) {
  502.             if (!isprint (UCHAR (*scanPtr)))
  503.                 break;
  504.         }
  505.         goto returnResult;
  506.     }
  507.     if ((class [1] == 'u') && STREQU (class, "punct")) {
  508.         for (; *scanPtr != 0; scanPtr++) {
  509.             if (!ispunct (UCHAR (*scanPtr)))
  510.                 break;
  511.         }
  512.         goto returnResult;
  513.     }
  514.     if (STREQU (class, "space")) {
  515.         for (; *scanPtr != 0; scanPtr++) {
  516.             if (!isspace (UCHAR (*scanPtr)))
  517.                 break;
  518.         }
  519.         goto returnResult;
  520.     }
  521.     if (STREQU (class, "upper")) {
  522.         for (; *scanPtr != 0; scanPtr++) {
  523.             if (!isupper (UCHAR (*scanPtr)))
  524.                 break;
  525.         }
  526.         goto returnResult;
  527.     }
  528.     if (STREQU (class, "xdigit")) {
  529.         for (; *scanPtr != 0; scanPtr++) {
  530.             if (!isxdigit (UCHAR (*scanPtr)))
  531.                 break;
  532.         }
  533.         goto returnResult;
  534.     }
  535.     /*
  536.      * No match on subcommand.
  537.      */
  538.     Tcl_AppendResult (interp, "unrecognized class specification: \"", class,
  539.                       "\", expected one of: alnum, alpha, ascii, char, ",
  540.                       "cntrl, digit, graph, lower, ord, print, punct, space, ",
  541.                       "upper or xdigit", (char *) NULL);
  542.     return TCL_ERROR;
  543.  
  544.     /*
  545.      * Return true or false, depending if the end was reached.  Always return 
  546.      * false for a null string.
  547.      */
  548. returnResult:
  549.     if ((*scanPtr == 0) && (scanPtr != argv [2]))
  550.         interp->result = "1";
  551.     else
  552.         interp->result = "0";
  553.     return TCL_OK;
  554.  
  555. }
  556.  
  557.