home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tclX6.5c / src / tclXstring.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-12-19  |  13.3 KB  |  499 lines
  1. /* 
  2.  * tclXstring.c --
  3.  *
  4.  *      Extended TCL string and character manipulation 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: tclXstring.c,v 2.0 1992/10/16 04:51:16 markd Rel $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. /*
  22.  * Prototypes of internal functions.
  23.  */
  24. 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;
  50.  
  51.     if (argc != 3) {
  52.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  53.                           " string indexExpr", (char *) NULL);
  54.         return TCL_ERROR;
  55.     }
  56.  
  57.     if (Tcl_ExprLong (interp, argv[2], &index) != TCL_OK)
  58.         return TCL_ERROR;
  59.     if (index >= strlen (argv [1]))
  60.         return TCL_OK;
  61.  
  62.     interp->result [0] = argv[1][index];
  63.     interp->result [1] = 0;
  64.     return TCL_OK;
  65.  
  66. } /* Tcl_CindexCmd */
  67.  
  68. /*
  69.  *-----------------------------------------------------------------------------
  70.  *
  71.  * Tcl_ClengthCmd --
  72.  *     Implements the clength TCL command:
  73.  *         clength string
  74.  *
  75.  * Results:
  76.  *      Returns the length of string in characters. 
  77.  *
  78.  *-----------------------------------------------------------------------------
  79.  */
  80. int
  81. Tcl_ClengthCmd (clientData, interp, argc, argv)
  82.     ClientData   clientData;
  83.     Tcl_Interp  *interp;
  84.     int          argc;
  85.     char       **argv;
  86. {
  87.  
  88.     if (argc != 2) {
  89.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " string", 
  90.                           (char *) NULL);
  91.         return TCL_ERROR;
  92.     }
  93.  
  94.     sprintf (interp->result, "%d", strlen (argv[1]));
  95.     return TCL_OK;
  96.  
  97. } /* Tcl_ClengthCmd */
  98.  
  99. /*
  100.  *-----------------------------------------------------------------------------
  101.  *
  102.  * Tcl_CrangeCmd --
  103.  *     Implements the crange and csubstr TCL commands:
  104.  *         crange string firstExpr lastExpr
  105.  *         csubstr string firstExpr lengthExpr
  106.  *
  107.  * Results:
  108.  *      Standard Tcl result.
  109.  *-----------------------------------------------------------------------------
  110.  */
  111. int
  112. Tcl_CrangeCmd (clientData, interp, argc, argv)
  113.     ClientData   clientData;
  114.     Tcl_Interp  *interp;
  115.     int          argc;
  116.     char       **argv;
  117. {
  118.     long      fullLen, first;
  119.     long      subLen;
  120.     char     *strPtr;
  121.     char      holdChar;
  122.     int       isRange = (argv [0][1] == 'r');  /* csubstr or crange */
  123.  
  124.     if (argc != 4) {
  125.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  126.                           " string firstExpr ", 
  127.                           (isRange) ? "lastExpr" : "lengthExpr",
  128.                           (char *) NULL);
  129.         return TCL_ERROR;
  130.     }
  131.  
  132.     if (Tcl_ExprLong (interp, argv[2], &first) != TCL_OK)
  133.         return TCL_ERROR;
  134.  
  135.     fullLen = strlen (argv [1]);
  136.     if (first >= fullLen)
  137.         return TCL_OK;
  138.  
  139.     if (STREQU (argv[3], "end"))
  140.         subLen = fullLen - first;
  141.     else {
  142.         if (Tcl_ExprLong (interp, argv[3], &subLen) != TCL_OK)
  143.             return TCL_ERROR;
  144.         
  145.         if (isRange) {
  146.             if (subLen < first) {
  147.                 Tcl_AppendResult (interp, "last is before first",
  148.                                   (char *) NULL);
  149.                 return TCL_ERROR;
  150.             }
  151.             subLen = subLen - first +1;
  152.         }
  153.  
  154.         if (first + subLen > fullLen)
  155.             subLen = fullLen - first;
  156.     }
  157.  
  158.     strPtr = argv [1] + first;
  159.  
  160.     holdChar = strPtr [subLen];
  161.     strPtr [subLen] = '\0';
  162.     Tcl_SetResult (interp, strPtr, TCL_VOLATILE);
  163.     strPtr [subLen] = holdChar;
  164.  
  165.     return TCL_OK;
  166.  
  167. } /* Tcl_CrangeCmd */
  168.  
  169. /*
  170.  *-----------------------------------------------------------------------------
  171.  *
  172.  * Tcl_ReplicateCmd --
  173.  *     Implements the replicate TCL command:
  174.  *         replicate string countExpr
  175.  *     See the string(TCL) manual page.
  176.  *
  177.  * Results:
  178.  *      Returns string replicated count times.
  179.  *
  180.  *-----------------------------------------------------------------------------
  181.  */
  182. int
  183. Tcl_ReplicateCmd (clientData, interp, argc, argv)
  184.     ClientData   clientData;
  185.     Tcl_Interp  *interp;
  186.     int          argc;
  187.     char       **argv;
  188. {
  189.     long           repCount;
  190.     register char *srcPtr, *scanPtr, *newPtr;
  191.     register long  newLen, cnt;
  192.  
  193.     if (argc != 3) {
  194.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  195.                           " string countExpr", (char *) NULL);
  196.         return TCL_ERROR;
  197.     }
  198.  
  199.     if (Tcl_ExprLong (interp, argv[2], &repCount) != TCL_OK)
  200.         return TCL_ERROR;
  201.  
  202.     srcPtr = argv [1];
  203.     newLen = strlen (srcPtr) * repCount;
  204.     if (newLen >= TCL_RESULT_SIZE)
  205.         Tcl_SetResult (interp, ckalloc ((unsigned) newLen + 1), TCL_DYNAMIC);
  206.  
  207.     newPtr = interp->result;
  208.     for (cnt = 0; cnt < repCount; cnt++) {
  209.         for (scanPtr = srcPtr; *scanPtr != 0; scanPtr++)
  210.             *newPtr++ = *scanPtr;
  211.     }
  212.     *newPtr = 0;
  213.  
  214.     return TCL_OK;
  215.  
  216. } /* Tcl_ReplicateCmd */
  217.  
  218. /*
  219.  *-----------------------------------------------------------------------------
  220.  *
  221.  * ExpandString --
  222.  *  Build an expand version of a translit range specification.
  223.  *
  224.  * Results:
  225.  *  TRUE it the expansion is ok, FALSE it its too long.
  226.  *
  227.  *-----------------------------------------------------------------------------
  228.  */
  229. #define MAX_EXPANSION 255
  230.  
  231. static unsigned int
  232. ExpandString (s, buf)
  233.     unsigned char *s;
  234.     unsigned char  buf[];
  235. {
  236.     int i, j;
  237.  
  238.     i = 0;
  239.     while((*s !=0) && i < MAX_EXPANSION) {
  240.         if(s[1] == '-' && s[2] > s[0]) {
  241.             for(j = s[0]; j <= s[2]; j++)
  242.                 buf[i++] = j;
  243.             s += 3;
  244.         } else
  245.             buf[i++] = *s++;
  246.     }
  247.     buf[i] = 0;
  248.     return (i < MAX_EXPANSION);
  249. }
  250.  
  251. /*
  252.  *-----------------------------------------------------------------------------
  253.  *
  254.  * Tcl_TranslitCmd --
  255.  *     Implements the TCL translit command:
  256.  *     translit inrange outrange string
  257.  *
  258.  * Results:
  259.  *  Standard TCL results.
  260.  *
  261.  *-----------------------------------------------------------------------------
  262.  */
  263. int
  264. Tcl_TranslitCmd (clientData, interp, argc, argv)
  265.     ClientData   clientData;
  266.     Tcl_Interp  *interp;
  267.     int          argc;
  268.     char       **argv;
  269. {
  270.     unsigned char from [MAX_EXPANSION+1];
  271.     unsigned char to   [MAX_EXPANSION+1];
  272.     unsigned char map  [MAX_EXPANSION+1];
  273.     unsigned char *s, *t;
  274.     int idx;
  275.  
  276.     if (argc != 4) {
  277.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  278.                           " from to string", (char *) NULL);
  279.         return TCL_ERROR;
  280.     }
  281.  
  282.     if (!ExpandString ((unsigned char *) argv[1], from)) {
  283.         interp->result = "inrange expansion too long";
  284.         return TCL_ERROR;
  285.     }
  286.  
  287.     if (!ExpandString ((unsigned char *) argv[2], to)) {
  288.         interp->result = "outrange expansion too long";
  289.         return TCL_ERROR;
  290.     }
  291.  
  292.     for (idx = 0; idx <= MAX_EXPANSION; idx++)
  293.         map [idx] = idx;
  294.  
  295.     for (idx = 0; to [idx] != '\0'; idx++) {
  296.         if (from [idx] != '\0')
  297.             map [from [idx]] = to [idx];
  298.         else
  299.             break;
  300.     }
  301.     if (to [idx] != '\0') {
  302.         interp->result = "inrange longer than outrange";
  303.         return TCL_ERROR;
  304.     }
  305.  
  306.     for (; from [idx] != '\0'; idx++)
  307.         map [from [idx]] = 0;
  308.  
  309.     for (s = t = (unsigned char *) argv[3]; *s != '\0'; s++) {
  310.         if (map[*s] != '\0')
  311.             *t++ = map [*s];
  312.     }
  313.     *t = '\0';
  314.  
  315.     Tcl_SetResult (interp, argv[3], TCL_VOLATILE);
  316.  
  317.     return TCL_OK;
  318. }
  319.  
  320. /*
  321.  *-----------------------------------------------------------------------------
  322.  *
  323.  * Tcl_CtypeCmd --
  324.  *
  325.  *      This function implements the 'ctype' command:
  326.  *      ctype class string
  327.  *
  328.  *      Where class is one of the following:
  329.  *        digit, xdigit, lower, upper, alpha, alnum,
  330.  *        space, cntrl,  punct, print, graph, ascii, char or ord.
  331.  *
  332.  * Results:
  333.  *       One or zero: Depending if all the characters in the string are of
  334.  *       the desired class.  Char and ord provide conversions and return the
  335.  *       converted value.
  336.  *
  337.  *-----------------------------------------------------------------------------
  338.  */
  339. int
  340. Tcl_CtypeCmd (clientData, interp, argc, argv)
  341.     ClientData   clientData;
  342.     Tcl_Interp  *interp;
  343.     int          argc;
  344.     char       **argv;
  345. {
  346.     register char *class;
  347.     register char *scanPtr = argv [2];
  348.  
  349.     if (argc != 3) {
  350.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " class string",
  351.                           (char *) NULL);
  352.         return TCL_ERROR;
  353.     }
  354.  
  355.     class = argv [1];
  356.  
  357.     /*
  358.      * Handle conversion requests.
  359.      */
  360.     if (STREQU (class, "char")) {
  361.         int number;
  362.  
  363.         if (Tcl_GetInt (interp, argv [2], &number) != TCL_OK)
  364.             return TCL_ERROR;
  365.         if ((number < 0) || (number > 255)) {
  366.             Tcl_AppendResult (interp, "number must be in the range 0..255",
  367.                               (char *) NULL);
  368.             return TCL_ERROR;
  369.         }
  370.  
  371.         interp->result [0] = number;
  372.         interp->result [1] = 0;
  373.         return TCL_OK;
  374.     }
  375.  
  376.     if (STREQU (class, "ord")) {
  377.         if (strlen (argv [2]) != 1) {
  378.             Tcl_AppendResult (interp, "string to convert must be only one",
  379.                               " character", (char *) NULL);
  380.             return TCL_ERROR;
  381.         }
  382.  
  383.         sprintf(interp->result, "%d", (int)(*argv[2]));
  384.         return TCL_OK;
  385.     }
  386.  
  387.     /*
  388.      * Select based on the first letter of the 'class' argument to chose the 
  389.      * macro to test characters with.  In some cases another character must be
  390.      * switched on to determine which macro to use.  This is gross, but better
  391.      * we only have to do a string compare once to test if class is correct.
  392.      */
  393.     if ((class [2] == 'n') && STREQU (class, "alnum")) {
  394.         for (; *scanPtr != 0; scanPtr++) {
  395.             if (!isalnum (*scanPtr))
  396.                 break;
  397.         }
  398.         goto returnResult;
  399.     }
  400.     if ((class [2] == 'p') && STREQU (class, "alpha")) {
  401.         for (; *scanPtr != 0; scanPtr++) {
  402.             if (! isalpha (*scanPtr))
  403.                 break;
  404.         }
  405.         goto returnResult;
  406.     }
  407.     if ((class [1] == 's') && STREQU (class, "ascii")) {
  408.         for (; *scanPtr != 0; scanPtr++) {
  409.             if (!isascii (*scanPtr))
  410.                 break;
  411.         }
  412.         goto returnResult;
  413.     }
  414.     if (STREQU (class, "cntrl")) {
  415.         for (; *scanPtr != 0; scanPtr++) {
  416.             if (!iscntrl (*scanPtr))
  417.                 break;
  418.         }
  419.         goto returnResult;
  420.     }
  421.     if (STREQU (class, "digit")) {
  422.         for (; *scanPtr != 0; scanPtr++) {
  423.             if (!isdigit (*scanPtr))
  424.                 break;
  425.         }
  426.         goto returnResult;
  427.     }
  428.     if (STREQU (class, "graph")) {
  429.         for (; *scanPtr != 0; scanPtr++) {
  430.             if (!isgraph (*scanPtr))
  431.                 break;
  432.         }
  433.         goto returnResult;
  434.     }
  435.     if (STREQU (class, "lower")) {
  436.         for (; *scanPtr != 0; scanPtr++) {
  437.             if (!islower (*scanPtr))
  438.                 break;
  439.         }
  440.         goto returnResult;
  441.     }
  442.     if ((class [1] == 'r') && STREQU (class, "print")) {
  443.         for (; *scanPtr != 0; scanPtr++) {
  444.             if (!isprint (*scanPtr))
  445.                 break;
  446.         }
  447.         goto returnResult;
  448.     }
  449.     if ((class [1] == 'u') && STREQU (class, "punct")) {
  450.         for (; *scanPtr != 0; scanPtr++) {
  451.             if (!ispunct (*scanPtr))
  452.                 break;
  453.         }
  454.         goto returnResult;
  455.     }
  456.     if (STREQU (class, "space")) {
  457.         for (; *scanPtr != 0; scanPtr++) {
  458.             if (!isspace (*scanPtr))
  459.                 break;
  460.         }
  461.         goto returnResult;
  462.     }
  463.     if (STREQU (class, "upper")) {
  464.         for (; *scanPtr != 0; scanPtr++) {
  465.             if (!isupper (*scanPtr))
  466.                 break;
  467.         }
  468.         goto returnResult;
  469.     }
  470.     if (STREQU (class, "xdigit")) {
  471.         for (; *scanPtr != 0; scanPtr++) {
  472.             if (!isxdigit (*scanPtr))
  473.                 break;
  474.         }
  475.         goto returnResult;
  476.     }
  477.     /*
  478.      * No match on subcommand.
  479.      */
  480.     Tcl_AppendResult (interp, "unrecognized class specification: \"", class,
  481.                       "\", expected one of: alnum, alpha, ascii, char, ",
  482.                       "cntrl, digit, graph, lower, ord, print, punct, space, ",
  483.                       "upper or xdigit", (char *) NULL);
  484.     return TCL_ERROR;
  485.  
  486.     /*
  487.      * Return true or false, depending if the end was reached.  Always return 
  488.      * false for a null string.
  489.      */
  490. returnResult:
  491.     if ((*scanPtr == 0) && (scanPtr != argv [2]))
  492.         interp->result = "1";
  493.     else
  494.         interp->result = "0";
  495.     return TCL_OK;
  496.  
  497. }
  498.  
  499.