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