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

   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 "tclxint.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 \f
  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 \f
  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 \f
  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 \f
 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 \f
 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 \f
 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 \f
 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