home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / src / tclXstring.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-19  |  17.4 KB  |  665 lines
  1. /* 
  2.  * tclXstring.c --
  3.  *
  4.  *      Extended TCL string and character manipulation commands.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1991-1993 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: tclXstring.c,v 3.0 1993/11/19 06:59:23 markd Rel $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. /*
  22.  * Prototypes of internal functions.
  23.  */
  24. static unsigned int
  25. ExpandString _ANSI_ARGS_((unsigned char *s,
  26.                           unsigned char  buf[]));
  27.  
  28.  
  29. /*
  30.  *-----------------------------------------------------------------------------
  31.  *
  32.  * Tcl_CindexCmd --
  33.  *     Implements the cindex TCL command:
  34.  *         cindex string indexExpr
  35.  *
  36.  * Results:
  37.  *      Returns the character indexed by  index  (zero  based)  from
  38.  *      string. 
  39.  *
  40.  *-----------------------------------------------------------------------------
  41.  */
  42. int
  43. Tcl_CindexCmd (clientData, interp, argc, argv)
  44.     ClientData   clientData;
  45.     Tcl_Interp  *interp;
  46.     int          argc;
  47.     char       **argv;
  48. {
  49.     long index, len;
  50.  
  51.     if (argc != 3) {
  52.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  53.                           " string indexExpr", (char *) NULL);
  54.         return TCL_ERROR;
  55.     }
  56.     
  57.     len = strlen (argv [1]);
  58.     if (Tcl_RelativeExpr (interp, argv[2], len, &index) != TCL_OK)
  59.         return TCL_ERROR;
  60.     if (index >= len)
  61.         return TCL_OK;
  62.  
  63.     interp->result [0] = argv[1][index];
  64.     interp->result [1] = 0;
  65.     return TCL_OK;
  66.  
  67. }
  68.  
  69. /*
  70.  *-----------------------------------------------------------------------------
  71.  *
  72.  * Tcl_ClengthCmd --
  73.  *     Implements the clength TCL command:
  74.  *         clength string
  75.  *
  76.  * Results:
  77.  *      Returns the length of string in characters. 
  78.  *
  79.  *-----------------------------------------------------------------------------
  80.  */
  81. int
  82. Tcl_ClengthCmd (clientData, interp, argc, argv)
  83.     ClientData   clientData;
  84.     Tcl_Interp  *interp;
  85.     int          argc;
  86.     char       **argv;
  87. {
  88.  
  89.     if (argc != 2) {
  90.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " string", 
  91.                           (char *) NULL);
  92.         return TCL_ERROR;
  93.     }
  94.  
  95.     sprintf (interp->result, "%d", strlen (argv[1]));
  96.     return TCL_OK;
  97.  
  98. }
  99.  
  100. /*
  101.  *-----------------------------------------------------------------------------
  102.  *
  103.  * Tcl_CrangeCmd --
  104.  *     Implements the crange and csubstr TCL commands:
  105.  *         crange string firstExpr lastExpr
  106.  *         csubstr string firstExpr lengthExpr
  107.  *
  108.  * Results:
  109.  *      Standard Tcl result.
  110.  *-----------------------------------------------------------------------------
  111.  */
  112. int
  113. Tcl_CrangeCmd (clientData, interp, argc, argv)
  114.     ClientData   clientData;
  115.     Tcl_Interp  *interp;
  116.     int          argc;
  117.     char       **argv;
  118. {
  119.     long      fullLen, first;
  120.     long      subLen;
  121.     char     *strPtr;
  122.     char      holdChar;
  123.     int       isRange = (argv [0][1] == 'r');  /* csubstr or crange */
  124.  
  125.     if (argc != 4) {
  126.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  127.                           " string firstExpr ", 
  128.                           (isRange) ? "lastExpr" : "lengthExpr",
  129.                           (char *) NULL);
  130.         return TCL_ERROR;
  131.     }
  132.  
  133.     fullLen = strlen (argv [1]);
  134.  
  135.     if (Tcl_RelativeExpr (interp, argv[2], fullLen, &first) != TCL_OK)
  136.         return TCL_ERROR;
  137.  
  138.     if (first >= fullLen)
  139.         return TCL_OK;
  140.  
  141.     if (Tcl_RelativeExpr (interp, argv[3], fullLen, &subLen) != TCL_OK)
  142.         return TCL_ERROR;
  143.         
  144.     if (isRange) {
  145.         if (subLen < first) {
  146.             Tcl_AppendResult (interp, "last is before first",
  147.                               (char *) NULL);
  148.             return TCL_ERROR;
  149.         }
  150.         subLen = subLen - first +1;
  151.     }
  152.  
  153.     if (first + subLen > fullLen)
  154.         subLen = fullLen - first;
  155.  
  156.     strPtr = argv [1] + first;
  157.  
  158.     holdChar = strPtr [subLen];
  159.     strPtr [subLen] = '\0';
  160.     Tcl_SetResult (interp, strPtr, TCL_VOLATILE);
  161.     strPtr [subLen] = holdChar;
  162.  
  163.     return TCL_OK;
  164. }
  165.  
  166. /*
  167.  *-----------------------------------------------------------------------------
  168.  *
  169.  * Tcl_ReplicateCmd --
  170.  *     Implements the replicate TCL command:
  171.  *         replicate string countExpr
  172.  *
  173.  * Results:
  174.  *      Returns string replicated count times.
  175.  *
  176.  *-----------------------------------------------------------------------------
  177.  */
  178. int
  179. Tcl_ReplicateCmd (clientData, interp, argc, argv)
  180.     ClientData   clientData;
  181.     Tcl_Interp  *interp;
  182.     int          argc;
  183.     char       **argv;
  184. {
  185.     long           repCount;
  186.     register char *srcPtr, *scanPtr, *newPtr;
  187.     register long  newLen, cnt;
  188.  
  189.     if (argc != 3) {
  190.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  191.                           " string countExpr", (char *) NULL);
  192.         return TCL_ERROR;
  193.     }
  194.  
  195.     if (Tcl_ExprLong (interp, argv[2], &repCount) != TCL_OK)
  196.         return TCL_ERROR;
  197.  
  198.     srcPtr = argv [1];
  199.     newLen = strlen (srcPtr) * repCount;
  200.     if (newLen >= TCL_RESULT_SIZE)
  201.         Tcl_SetResult (interp, ckalloc ((unsigned) newLen + 1), TCL_DYNAMIC);
  202.  
  203.     newPtr = interp->result;
  204.     for (cnt = 0; cnt < repCount; cnt++) {
  205.         for (scanPtr = srcPtr; *scanPtr != 0; scanPtr++)
  206.             *newPtr++ = *scanPtr;
  207.     }
  208.     *newPtr = 0;
  209.  
  210.     return TCL_OK;
  211.  
  212. }
  213.  
  214. /*
  215.  *-----------------------------------------------------------------------------
  216.  *
  217.  * Tcl_CtokenCmd --
  218.  *     Implements the clength TCL command:
  219.  *         ctoken strvar separators
  220.  *
  221.  * Results:
  222.  *      Returns the first token and removes it from the string variable.
  223.  *
  224.  *-----------------------------------------------------------------------------
  225.  */
  226. int
  227. Tcl_CtokenCmd (clientData, interp, argc, argv)
  228.     ClientData   clientData;
  229.     Tcl_Interp  *interp;
  230.     int          argc;
  231.     char       **argv;
  232. {
  233.     Tcl_DString  string;
  234.     char        *varValue, *startPtr;
  235.     int          tokenLen;
  236.  
  237.     if (argc != 3) {
  238.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  239.                           " strvar separators", (char *) NULL);
  240.         return TCL_ERROR;
  241.     }
  242.     
  243.     varValue = Tcl_GetVar (interp, argv [1], TCL_LEAVE_ERR_MSG);
  244.     if (varValue == NULL)
  245.         return TCL_ERROR;
  246.  
  247.     Tcl_DStringInit (&string);
  248.     Tcl_DStringAppend (&string, varValue, -1);
  249.  
  250.     startPtr = string.string + strspn (string.string, argv [2]);
  251.     tokenLen = strcspn (startPtr, argv [2]);
  252.  
  253.     if (Tcl_SetVar (interp, argv [1], startPtr + tokenLen,
  254.                     TCL_LEAVE_ERR_MSG) == NULL) {
  255.         Tcl_DStringFree (&string);
  256.         return TCL_ERROR;
  257.     }
  258.     startPtr [tokenLen] = '\0';
  259.     Tcl_SetResult (interp, startPtr, TCL_VOLATILE);
  260.     Tcl_DStringFree (&string);
  261.  
  262.     return TCL_OK;
  263. }
  264.  
  265. /*
  266.  *-----------------------------------------------------------------------------
  267.  *
  268.  * Tcl_CexpandCmd --
  269.  *     Implements the cexpand TCL command:
  270.  *         cexpand string
  271.  *
  272.  * Results:
  273.  *   Returns the character with backslash sequences expanded into actual
  274.  * characters.
  275.  *-----------------------------------------------------------------------------
  276.  */
  277. int
  278. Tcl_CexpandCmd (clientData, interp, argc, argv)
  279.     ClientData   clientData;
  280.     Tcl_Interp  *interp;
  281.     int          argc;
  282.     char       **argv;
  283. {
  284.     Tcl_DString    expanded;
  285.     register char *scanPtr, *lastPtr;
  286.     char           buf [1];
  287.     int            count;
  288.  
  289.     if (argc != 2) {
  290.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  291.                           " string", (char *) NULL);
  292.         return TCL_ERROR;
  293.     }
  294.  
  295.     Tcl_DStringInit (&expanded);
  296.     scanPtr = lastPtr = argv [1];
  297.  
  298.     while (*scanPtr != '\0') {
  299.         if (*scanPtr != '\\') {
  300.             scanPtr++;
  301.             continue;
  302.         }
  303.         /*
  304.          * Found a backslash.
  305.          */
  306.         Tcl_DStringAppend (&expanded, lastPtr, scanPtr - lastPtr);
  307.         buf [0] = Tcl_Backslash (scanPtr, &count);
  308.         Tcl_DStringAppend (&expanded, buf, 1);
  309.         scanPtr += count;
  310.         lastPtr = scanPtr;
  311.     }
  312.     Tcl_DStringAppend (&expanded, lastPtr, scanPtr - lastPtr);
  313.     
  314.     Tcl_DStringResult (interp, &expanded);
  315.     return TCL_OK;
  316. }
  317.  
  318. /*
  319.  *-----------------------------------------------------------------------------
  320.  *
  321.  * Tcl_CequalCmd --
  322.  *     Implements the cexpand TCL command:
  323.  *         cequal string1 string2
  324.  *
  325.  * Results:
  326.  *   "0" or "1".
  327.  *-----------------------------------------------------------------------------
  328.  */
  329. int
  330. Tcl_CequalCmd (clientData, interp, argc, argv)
  331.     ClientData   clientData;
  332.     Tcl_Interp  *interp;
  333.     int          argc;
  334.     char       **argv;
  335. {
  336.     if (argc != 3) {
  337.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  338.                           " string1 string2", (char *) NULL);
  339.         return TCL_ERROR;
  340.     }
  341.     interp->result = (strcmp (argv [1], argv [2]) == 0) ? "1" : "0";
  342.     return TCL_OK;
  343. }
  344.  
  345. /*
  346.  *-----------------------------------------------------------------------------
  347.  *
  348.  * ExpandString --
  349.  *  Build an expand version of a translit range specification.
  350.  *
  351.  * Results:
  352.  *  TRUE it the expansion is ok, FALSE it its too long.
  353.  *
  354.  *-----------------------------------------------------------------------------
  355.  */
  356. #define MAX_EXPANSION 255
  357.  
  358. static unsigned int
  359. ExpandString (s, buf)
  360.     unsigned char *s;
  361.     unsigned char  buf[];
  362. {
  363.     int i, j;
  364.  
  365.     i = 0;
  366.     while((*s !=0) && i < MAX_EXPANSION) {
  367.         if(s[1] == '-' && s[2] > s[0]) {
  368.             for(j = s[0]; j <= s[2]; j++)
  369.                 buf[i++] = j;
  370.             s += 3;
  371.         } else
  372.             buf[i++] = *s++;
  373.     }
  374.     buf[i] = 0;
  375.     return (i < MAX_EXPANSION);
  376. }
  377.  
  378. /*
  379.  *-----------------------------------------------------------------------------
  380.  *
  381.  * Tcl_TranslitCmd --
  382.  *     Implements the TCL translit command:
  383.  *     translit inrange outrange string
  384.  *
  385.  * Results:
  386.  *  Standard TCL results.
  387.  *
  388.  *-----------------------------------------------------------------------------
  389.  */
  390. int
  391. Tcl_TranslitCmd (clientData, interp, argc, argv)
  392.     ClientData   clientData;
  393.     Tcl_Interp  *interp;
  394.     int          argc;
  395.     char       **argv;
  396. {
  397.     unsigned char from [MAX_EXPANSION+1];
  398.     unsigned char to   [MAX_EXPANSION+1];
  399.     unsigned char map  [MAX_EXPANSION+1];
  400.     unsigned char *s, *t;
  401.     int idx;
  402.  
  403.     if (argc != 4) {
  404.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  405.                           " from to string", (char *) NULL);
  406.         return TCL_ERROR;
  407.     }
  408.  
  409.     if (!ExpandString ((unsigned char *) argv[1], from)) {
  410.         interp->result = "inrange expansion too long";
  411.         return TCL_ERROR;
  412.     }
  413.  
  414.     if (!ExpandString ((unsigned char *) argv[2], to)) {
  415.         interp->result = "outrange expansion too long";
  416.         return TCL_ERROR;
  417.     }
  418.  
  419.     for (idx = 0; idx <= MAX_EXPANSION; idx++)
  420.         map [idx] = idx;
  421.  
  422.     for (idx = 0; to [idx] != '\0'; idx++) {
  423.         if (from [idx] != '\0')
  424.             map [from [idx]] = to [idx];
  425.         else
  426.             break;
  427.     }
  428.     if (to [idx] != '\0') {
  429.         interp->result = "inrange longer than outrange";
  430.         return TCL_ERROR;
  431.     }
  432.  
  433.     for (; from [idx] != '\0'; idx++)
  434.         map [from [idx]] = 0;
  435.  
  436.     for (s = t = (unsigned char *) argv[3]; *s != '\0'; s++) {
  437.         if (map[*s] != '\0')
  438.             *t++ = map [*s];
  439.     }
  440.     *t = '\0';
  441.  
  442.     Tcl_SetResult (interp, argv[3], TCL_VOLATILE);
  443.  
  444.     return TCL_OK;
  445. }
  446.  
  447. /*
  448.  *-----------------------------------------------------------------------------
  449.  *
  450.  * Tcl_CtypeCmd --
  451.  *
  452.  *      This function implements the 'ctype' command:
  453.  *      ctype ?-failindex? class string ?failIndexVar?
  454.  *
  455.  *      Where class is one of the following:
  456.  *        digit, xdigit, lower, upper, alpha, alnum,
  457.  *        space, cntrl,  punct, print, graph, ascii, char or ord.
  458.  *
  459.  * Results:
  460.  *       One or zero: Depending if all the characters in the string are of
  461.  *       the desired class.  Char and ord provide conversions and return the
  462.  *       converted value.
  463.  *
  464.  *-----------------------------------------------------------------------------
  465.  */
  466. int
  467. Tcl_CtypeCmd (clientData, interp, argc, argv)
  468.     ClientData   clientData;
  469.     Tcl_Interp  *interp;
  470.     int          argc;
  471.     char       **argv;
  472. {
  473.     int             failIndex = FALSE;
  474.     char           *failVar;
  475.     register char  *class;
  476.     char           *string;
  477.     register char  *scanPtr;
  478.  
  479.     if (argc < 3)
  480.     goto wrongNumArgs;
  481.  
  482.     if (argv [1][0] == '-') {
  483.     if (STREQU (argv [1], "-failindex")) {
  484.         failIndex = TRUE;
  485.     } else {
  486.         Tcl_AppendResult(interp, "invalid option \"", argv [1],
  487.         "\", must be -failindex", (char *) NULL);
  488.         return TCL_ERROR;
  489.     }
  490.     }
  491.     if (failIndex) {
  492.         if (argc != 5) 
  493.             goto wrongNumArgs;
  494.         failVar = argv [2];
  495.         class = argv [3];
  496.         string = argv [4];
  497.     } else {
  498.         if (argc != 3) 
  499.             goto wrongNumArgs;
  500.         class = argv [1];
  501.         string = argv [2];
  502.     }
  503.     scanPtr = string;
  504.  
  505.     /*
  506.      * Handle conversion requests.
  507.      */
  508.     if (STREQU (class, "char")) {
  509.         int number;
  510.  
  511.         if (failIndex) 
  512.           goto failInvalid;
  513.         if (Tcl_GetInt (interp, scanPtr, &number) != TCL_OK)
  514.             return TCL_ERROR;
  515.         if ((number < 0) || (number > 255)) {
  516.             Tcl_AppendResult (interp, "number must be in the range 0..255",
  517.                               (char *) NULL);
  518.             return TCL_ERROR;
  519.         }
  520.  
  521.         interp->result [0] = number;
  522.         interp->result [1] = 0;
  523.         return TCL_OK;
  524.     }
  525.  
  526.     if (STREQU (class, "ord")) {
  527.         int value;
  528.  
  529.         if (failIndex) 
  530.           goto failInvalid;
  531.  
  532.         value = 0xff & scanPtr[0];  /* Prevent sign extension */
  533.         sprintf (interp->result, "%u", value);
  534.         return TCL_OK;
  535.     }
  536.  
  537.     if (STREQU (class, "alnum")) {
  538.         for (; *scanPtr != 0; scanPtr++) {
  539.             if (!isalnum (UCHAR (*scanPtr)))
  540.                 break;
  541.         }
  542.         goto returnResult;
  543.     }
  544.     if (STREQU (class, "alpha")) {
  545.         for (; *scanPtr != 0; scanPtr++) {
  546.             if (!isalpha (UCHAR (*scanPtr)))
  547.                 break;
  548.         }
  549.         goto returnResult;
  550.     }
  551.     if (STREQU (class, "ascii")) {
  552.         for (; *scanPtr != 0; scanPtr++) {
  553.             if (!isascii (UCHAR (*scanPtr)))
  554.                 break;
  555.         }
  556.         goto returnResult;
  557.     }
  558.     if (STREQU (class, "cntrl")) {
  559.         for (; *scanPtr != 0; scanPtr++) {
  560.             if (!iscntrl (UCHAR (*scanPtr)))
  561.                 break;
  562.         }
  563.         goto returnResult;
  564.     }
  565.     if (STREQU (class, "digit")) {
  566.         for (; *scanPtr != 0; scanPtr++) {
  567.             if (!isdigit (UCHAR (*scanPtr)))
  568.                 break;
  569.         }
  570.         goto returnResult;
  571.     }
  572.     if (STREQU (class, "graph")) {
  573.         for (; *scanPtr != 0; scanPtr++) {
  574.             if (!isgraph (UCHAR (*scanPtr)))
  575.                 break;
  576.         }
  577.         goto returnResult;
  578.     }
  579.     if (STREQU (class, "lower")) {
  580.         for (; *scanPtr != 0; scanPtr++) {
  581.             if (!islower (UCHAR (*scanPtr)))
  582.                 break;
  583.         }
  584.         goto returnResult;
  585.     }
  586.     if (STREQU (class, "print")) {
  587.         for (; *scanPtr != 0; scanPtr++) {
  588.             if (!isprint (UCHAR (*scanPtr)))
  589.                 break;
  590.         }
  591.         goto returnResult;
  592.     }
  593.     if (STREQU (class, "punct")) {
  594.         for (; *scanPtr != 0; scanPtr++) {
  595.             if (!ispunct (UCHAR (*scanPtr)))
  596.                 break;
  597.         }
  598.         goto returnResult;
  599.     }
  600.     if (STREQU (class, "space")) {
  601.         for (; *scanPtr != 0; scanPtr++) {
  602.             if (!isspace (UCHAR (*scanPtr)))
  603.                 break;
  604.         }
  605.         goto returnResult;
  606.     }
  607.     if (STREQU (class, "upper")) {
  608.         for (; *scanPtr != 0; scanPtr++) {
  609.             if (!isupper (UCHAR (*scanPtr)))
  610.                 break;
  611.         }
  612.         goto returnResult;
  613.     }
  614.     if (STREQU (class, "xdigit")) {
  615.         for (; *scanPtr != 0; scanPtr++) {
  616.             if (!isxdigit (UCHAR (*scanPtr)))
  617.                 break;
  618.         }
  619.         goto returnResult;
  620.     }
  621.     /*
  622.      * No match on class.
  623.      */
  624.     Tcl_AppendResult (interp, "unrecognized class specification: \"", class,
  625.                       "\", expected one of: alnum, alpha, ascii, char, ",
  626.                       "cntrl, digit, graph, lower, ord, print, punct, space, ",
  627.                       "upper or xdigit", (char *) NULL);
  628.     return TCL_ERROR;
  629.  
  630.     /*
  631.      * Return true or false, depending if the end was reached.  Always return 
  632.      * false for a null string.  Optionally return the failed index if there
  633.      * is no match.
  634.      */
  635.   returnResult:
  636.     if ((*scanPtr == 0) && (scanPtr != string))
  637.         interp->result = "1";
  638.     else {
  639.         /*
  640.          * If the fail index was requested, set the variable here.
  641.          */
  642.         if (failIndex) {
  643.             char indexStr [50];
  644.  
  645.             sprintf (indexStr, "%d", scanPtr - string);
  646.             if (Tcl_SetVar(interp, failVar, indexStr,
  647.                            TCL_LEAVE_ERR_MSG) == NULL)
  648.                 return TCL_ERROR;
  649.         }
  650.         interp->result = "0";
  651.     }
  652.     return TCL_OK;
  653.  
  654.   wrongNumArgs:
  655.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  656.                       " ?-failindex var? class string",
  657.                       (char *) NULL);
  658.     return TCL_ERROR;
  659.     
  660.   failInvalid:
  661.     Tcl_AppendResult (interp, "-failindex option is invalid for class \"",
  662.                       class, "\"", (char *) NULL);
  663.     return TCL_ERROR;
  664. }
  665.