cvs.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxutil.c

   1 /*
   2  * tclXutil.c
   3  *
   4  * Utility functions for Extended Tcl.
   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: tclXutil.c,v 2.0 1992/10/16 04:51:21 markd Rel $
  16  *-----------------------------------------------------------------------------
  17  */
  18
  19 #include "tclxint.h"
  20
  21 #ifndef _tolower
  22 #  define _tolower tolower
  23 #  define _toupper toupper
  24 #endif
  25
  26 /*
  27  * Used to return argument messages by most commands.
  28  */
  29 char *tclXWrongArgs = "wrong # args: ";
  30
  31 extern double pow (double, double);
  32
  33 \f
  34 /*
  35  *-----------------------------------------------------------------------------
  36  *
  37  * Tcl_StrToLong --
  38  *      Convert an Ascii string to an long number of the specified base.
  39  *
  40  * Parameters:
  41  *   o string (I) - String containing a number.
  42  *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
  43  *     based on the leading characters of the number.  Zero to let the number
  44  *     determine the base.
  45  *   o longPtr (O) - Place to return the converted number.  Will be
  46  *     unchanged if there is an error.
  47  *
  48  * Returns:
  49  *      Returns 1 if the string was a valid number, 0 invalid.
  50  *-----------------------------------------------------------------------------
  51  */
  52 int
  53 Tcl_StrToLong (CONST char *string, int base, long *longPtr)
  54 {
  55     char *end;
  56     long  num;
  57
  58     num = strtol(string, &end, base);
  59     while ((*end != '\0') && isspace(*end)) {
  60         end++;
  61     }
  62     if ((end == string) || (*end != 0))
  63         return FALSE;
  64     *longPtr = num;
  65     return TRUE;
  66
  67 } /* Tcl_StrToLong */
  68 \f
  69 /*
  70  *-----------------------------------------------------------------------------
  71  *
  72  * Tcl_StrToInt --
  73  *      Convert an Ascii string to an number of the specified base.
  74  *
  75  * Parameters:
  76  *   o string (I) - String containing a number.
  77  *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
  78  *     based on the leading characters of the number.  Zero to let the number
  79  *     determine the base.
  80  *   o intPtr (O) - Place to return the converted number.  Will be
  81  *     unchanged if there is an error.
  82  *
  83  * Returns:
  84  *      Returns 1 if the string was a valid number, 0 invalid.
  85  *-----------------------------------------------------------------------------
  86  */
  87 int
  88 Tcl_StrToInt (CONST char *string, int base, int *intPtr)
  89 {
  90     char *end;
  91     int   num;
  92
  93     num = strtol(string, &end, base);
  94     while ((*end != '\0') && isspace(*end)) {
  95         end++;
  96     }
  97     if ((end == string) || (*end != 0))
  98         return FALSE;
  99     *intPtr = num;
 100     return TRUE;
 101
 102 } /* Tcl_StrToInt */
 103 \f
 104 /*
 105  *-----------------------------------------------------------------------------
 106  *
 107  * Tcl_StrToUnsigned --
 108  *      Convert an Ascii string to an unsigned int of the specified base.
 109  *
 110  * Parameters:
 111  *   o string (I) - String containing a number.
 112  *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
 113  *     based on the leading characters of the number.  Zero to let the number
 114  *     determine the base.
 115  *   o unsignedPtr (O) - Place to return the converted number.  Will be
 116  *     unchanged if there is an error.
 117  *
 118  * Returns:
 119  *      Returns 1 if the string was a valid number, 0 invalid.
 120  *-----------------------------------------------------------------------------
 121  */
 122 int
 123 Tcl_StrToUnsigned (CONST char *string, int base, unsigned *unsignedPtr)
 124 {
 125     char          *end;
 126     unsigned long  num;
 127
 128     num = strtoul (string, &end, base);
 129     while ((*end != '\0') && isspace(*end)) {
 130         end++;
 131     }
 132     if ((end == string) || (*end != 0))
 133         return FALSE;
 134     *unsignedPtr = num;
 135     return TRUE;
 136
 137 } /* Tcl_StrToUnsigned */
 138 \f
 139 /*
 140  *-----------------------------------------------------------------------------
 141  *
 142  * Tcl_StrToDouble --
 143  *   Convert a string to a double percision floating point number.
 144  *
 145  * Parameters:
 146  *   string (I) - Buffer containing double value to convert.
 147  *   doublePtr (O) - The convert floating point number.
 148  * Returns:
 149  *   TRUE if the number is ok, FALSE if it is illegal.
 150  *-----------------------------------------------------------------------------
 151  */
 152 int
 153 Tcl_StrToDouble (CONST char *string, double *doublePtr)
 154 {
 155     char   *end;
 156     double  num;
 157
 158     num = strtod (string, &end);
 159     while ((*end != '\0') && isspace(*end)) {
 160         end++;
 161     }
 162     if ((end == string) || (*end != 0))
 163         return FALSE;
 164
 165     *doublePtr = num;
 166     return TRUE;
 167
 168 } /* Tcl_StrToDouble */
 169 \f
 170 /*
 171  *-----------------------------------------------------------------------------
 172  *
 173  * Tcl_DownShift --
 174  *     Utility procedure to down-shift a string.  It is written in such
 175  *     a way as that the target string maybe the same as the source string.
 176  *
 177  * Parameters:
 178  *   o targetStr (I) - String to store the down-shifted string in.  Must
 179  *     have enough space allocated to store the string.  If NULL is specified,
 180  *     then the string will be dynamicly allocated and returned as the
 181  *     result of the function. May also be the same as the source string to
 182  *     shift in place.
 183  *   o sourceStr (I) - The string to down-shift.
 184  *
 185  * Returns:
 186  *   A pointer to the down-shifted string
 187  *-----------------------------------------------------------------------------
 188  */
 189 char *
 190 Tcl_DownShift (char *targetStr, CONST char *sourceStr)
 191 {
 192     register char theChar;
 193
 194     if (targetStr == NULL)
 195         targetStr = ckalloc (strlen ((char *) sourceStr) + 1);
 196
 197     for (; (theChar = *sourceStr) != '\0'; sourceStr++) {
 198         if (isupper (theChar))
 199             theChar = _tolower (theChar);
 200         *targetStr++ = theChar;
 201     }
 202     *targetStr = '\0';
 203     return targetStr;
 204 }
 205 \f
 206 /*
 207  *-----------------------------------------------------------------------------
 208  *
 209  * Tcl_UpShift --
 210  *     Utility procedure to up-shift a string.
 211  *
 212  * Parameters:
 213  *   o targetStr (I) - String to store the up-shifted string in.  Must
 214  *     have enough space allocated to store the string.  If NULL is specified,
 215  *     then the string will be dynamicly allocated and returned as the
 216  *     result of the function. May also be the same as the source string to
 217  *     shift in place.
 218  *   o sourceStr (I) - The string to up-shift.
 219  *
 220  * Returns:
 221  *   A pointer to the up-shifted string
 222  *-----------------------------------------------------------------------------
 223  */
 224 char *
 225 Tcl_UpShift (char *targetStr, CONST char *sourceStr)
 226 {
 227     register char theChar;
 228
 229     if (targetStr == NULL)
 230         targetStr = ckalloc (strlen ((char *) sourceStr) + 1);
 231
 232     for (; (theChar = *sourceStr) != '\0'; sourceStr++) {
 233         if (islower (theChar))
 234             theChar = _toupper (theChar);
 235         *targetStr++ = theChar;
 236     }
 237     *targetStr = '\0';
 238     return targetStr;
 239 }
 240 \f
 241 /*
 242  *-----------------------------------------------------------------------------
 243  *
 244  * Tcl_ExpandDynBuf --
 245  *
 246  *    Expand a dynamic buffer so that it will have room to hold the
 247  *    specified additional space.  If `appendSize' is zero, the buffer
 248  *    size will just be doubled.
 249  *
 250  *-----------------------------------------------------------------------------
 251  */
 252 void
 253 Tcl_ExpandDynBuf (dynamicBuf_t *dynBufPtr, int appendSize)
 254 {
 255     int   newSize, minSize;
 256     char *oldBufPtr;
 257
 258     newSize = dynBufPtr->size * 2;
 259     minSize = dynBufPtr->len + 1 + appendSize;
 260     if (newSize < minSize)
 261         newSize = minSize;
 262
 263     oldBufPtr = dynBufPtr->ptr;
 264     dynBufPtr->ptr = ckalloc (newSize);
 265     memcpy (dynBufPtr->ptr, oldBufPtr, dynBufPtr->len + 1);
 266     if (oldBufPtr != dynBufPtr->buf)
 267         ckfree ((char *) oldBufPtr);
 268     dynBufPtr->size = newSize;
 269 }
 270 \f
 271 /*
 272  *-----------------------------------------------------------------------------
 273  *
 274  * Tcl_DynBufInit --
 275  *
 276  *    Initializes a dynamic buffer.
 277  *
 278  *-----------------------------------------------------------------------------
 279  */
 280 void
 281 Tcl_DynBufInit (dynamicBuf_t *dynBufPtr)
 282 {
 283     dynBufPtr->buf [0] = '\0';
 284     dynBufPtr->ptr = dynBufPtr->buf;
 285     dynBufPtr->size = INIT_DYN_BUFFER_SIZE;
 286     dynBufPtr->len = 0;
 287 }
 288 \f
 289 /*
 290  *-----------------------------------------------------------------------------
 291  *
 292  * Tcl_DynBufFree --
 293  *
 294  *    Clean up a dynamic buffer, release space if it was dynamicly
 295  * allocated.
 296  *
 297  *-----------------------------------------------------------------------------
 298  */
 299 void
 300 Tcl_DynBufFree (dynamicBuf_t *dynBufPtr)
 301 {
 302     if (dynBufPtr->ptr != dynBufPtr->buf)
 303         ckfree (dynBufPtr->ptr);
 304 }
 305 \f
 306 /*
 307  *-----------------------------------------------------------------------------
 308  *
 309  * Tcl_DynBufReturn --
 310  *
 311  *    Return the contents of the dynamic buffer as an interpreter result.
 312  * Don't call DynBufFree after calling this procedure.  The dynamic buffer
 313  * must be re-initialized to reuse it.
 314  *
 315  *-----------------------------------------------------------------------------
 316  */
 317 void
 318 Tcl_DynBufReturn (Tcl_Interp *interp, dynamicBuf_t *dynBufPtr)
 319 {
 320     if (dynBufPtr->ptr != dynBufPtr->buf)
 321         Tcl_SetResult (interp, dynBufPtr->ptr, TCL_DYNAMIC);
 322     else
 323         Tcl_SetResult (interp, dynBufPtr->ptr, TCL_VOLATILE);
 324 }
 325 \f
 326 /*
 327  *-----------------------------------------------------------------------------
 328  *
 329  * Tcl_DynBufAppend --
 330  *
 331  *    Append the specified string to the dynamic buffer, expanding if
 332  *    necessary. Assumes the string in the buffer is zero terminated.
 333  *
 334  *-----------------------------------------------------------------------------
 335  */
 336 void
 337 Tcl_DynBufAppend (dynamicBuf_t *dynBufPtr, char *newStr)
 338 {
 339     int newLen, currentUsed;
 340
 341     newLen = strlen (newStr);
 342     if ((dynBufPtr->len + newLen + 1) > dynBufPtr->size)
 343         Tcl_ExpandDynBuf (dynBufPtr, newLen);
 344     strcpy (dynBufPtr->ptr + dynBufPtr->len, newStr);
 345     dynBufPtr->len += newLen;
 346 }
 347 \f
 348 /*
 349  *-----------------------------------------------------------------------------
 350  *
 351  * Tcl_DynamicFgets --
 352  *
 353  *    Reads a line from a file into a dynamic buffer.  The buffer will be
 354  * expanded, if necessary and reads are done until EOL or EOF is reached.
 355  * Any data already in the buffer will be overwritten. if append is not
 356  * specified.  Even if an error or EOF is encountered, the buffer should
 357  * be cleaned up, as storage may have still been allocated.
 358  *
 359  * Results:
 360  *    If data was transfered, returns 1, if EOF was encountered without
 361  * transfering any data, returns 0.  If an error occured, returns, -1.
 362  *
 363  *-----------------------------------------------------------------------------
 364  */
 365 int
 366 Tcl_DynamicFgets (dynamicBuf_t *dynBufPtr, FILE *filePtr, int append)
 367 {
 368     int   readVal;
 369
 370     if (!append)
 371         dynBufPtr->len = 0;
 372
 373     while (TRUE) {
 374         if (dynBufPtr->len + 1 == dynBufPtr->size)
 375             Tcl_ExpandDynBuf (dynBufPtr, 0);
 376
 377         readVal = getc (filePtr);
 378         if (readVal == '\n')      /* Is it a new-line? */
 379             break;
 380         if (readVal == EOF) {     /* Is it an EOF or an error? */
 381             if (feof (filePtr)) {
 382                 break;
 383             }
 384             return -1;   /* Error */
 385         }
 386         dynBufPtr->ptr [dynBufPtr->len++] = readVal;
 387     }
 388     dynBufPtr->ptr [dynBufPtr->len] = '\0';
 389     return (readVal == EOF) ? 0 : 1;
 390 }
 391 \f
 392 /*
 393  *-----------------------------------------------------------------------------
 394  *
 395  * Tcl_GetLong --
 396  *
 397  *      Given a string, produce the corresponding long value.
 398  *
 399  * Results:
 400  *      The return value is normally TCL_OK;  in this case *intPtr
 401  *      will be set to the integer value equivalent to string.  If
 402  *      string is improperly formed then TCL_ERROR is returned and
 403  *      an error message will be left in interp->result.
 404  *
 405  * Side effects:
 406  *      None.
 407  *
 408  *-----------------------------------------------------------------------------
 409  */
 410 int
 411 Tcl_GetLong (
 412     Tcl_Interp *interp,         /* Interpreter to use for error reporting. */
 413     CONST char *string,         /* String containing a (possibly signed)
 414                                  * integer in a form acceptable to strtol. */
 415     long *longPtr        /* Place to store converted result. */
 416 )
 417 {
 418     char *end;
 419     long  i;
 420
 421     i = strtol(string, &end, 0);
 422     while ((*end != '\0') && isspace(*end)) {
 423         end++;
 424     }
 425     if ((end == string) || (*end != 0)) {
 426         Tcl_AppendResult (interp, "expected integer but got \"", string,
 427                           "\"", (char *) NULL);
 428         return TCL_ERROR;
 429     }
 430     *longPtr = i;
 431     return TCL_OK;
 432 }
 433 \f
 434 /*
 435  *-----------------------------------------------------------------------------
 436  *
 437  * Tcl_GetUnsigned --
 438  *
 439  *      Given a string, produce the corresponding unsigned integer value.
 440  *
 441  * Results:
 442  *      The return value is normally TCL_OK;  in this case *intPtr
 443  *      will be set to the integer value equivalent to string.  If
 444  *      string is improperly formed then TCL_ERROR is returned and
 445  *      an error message will be left in interp->result.
 446  *
 447  * Side effects:
 448  *      None.
 449  *
 450  *-----------------------------------------------------------------------------
 451  */
 452 int
 453 Tcl_GetUnsigned (
 454     Tcl_Interp *interp,         /* Interpreter to use for error reporting. */
 455     CONST char *string,         /* String containing a (possibly signed)
 456                                  * integer in a form acceptable to strtoul. */
 457     unsigned *unsignedPtr    /* Place to store converted result. */
 458 )
 459 {
 460     char          *end;
 461     unsigned long  i;
 462
 463     /*
 464      * Since some strtoul functions don't detect negative numbers, check
 465      * in advance.
 466      */
 467     while (isspace(*string))
 468         string++;
 469     if (string [0] == '-')
 470         goto badUnsigned;
 471
 472     i = strtoul(string, &end, 0);
 473     while ((*end != '\0') && isspace(*end))
 474         end++;
 475
 476     if ((end == string) || (*end != '\0'))
 477         goto badUnsigned;
 478
 479     *unsignedPtr = i;
 480     return TCL_OK;
 481
 482   badUnsigned:
 483     Tcl_AppendResult (interp, "expected unsigned integer but got \"",
 484                       string, "\"", (char *) NULL);
 485     return TCL_ERROR;
 486 }
 487 \f
 488 /*
 489  *-----------------------------------------------------------------------------
 490  *
 491  * Tcl_ConvertFileHandle --
 492  *
 493  * Convert a file handle to its file number. The file handle maybe one
 494  * of "stdin", "stdout" or "stderr" or "fileNNN", were NNN is the file
 495  * number.  If the handle is invalid, -1 is returned and a error message
 496  * will be returned in interp->result.  This is used when the file may
 497  * not be currently open.
 498  *
 499  *-----------------------------------------------------------------------------
 500  */
 501 int
 502 Tcl_ConvertFileHandle (Tcl_Interp *interp, char *handle)
 503 {
 504     int fileId = -1;
 505
 506     if (handle [0] == 's') {
 507         if (STREQU (handle, "stdin"))
 508             fileId = 0;
 509         else if (STREQU (handle, "stdout"))
 510             fileId = 1;
 511         else if (STREQU (handle, "stderr"))
 512             fileId = 2;
 513     } else {
 514        if (STRNEQU (handle, "file", 4))
 515            Tcl_StrToInt (&handle [4], 10, &fileId);
 516     }
 517     if (fileId < 0)
 518         Tcl_AppendResult (interp, "invalid file handle: ", handle,
 519                           (char *) NULL);
 520     return fileId;
 521 }
 522 \f
 523 /*
 524  *-----------------------------------------------------------------------------
 525  *
 526  * Tcl_SetupFileEntry --
 527  *
 528  * Set up an entry in the Tcl file table for a file number, including the stdio
 529  * FILE structure.
 530  *
 531  * Parameters:
 532  *   o interp (I) - Current interpreter.
 533  *   o fileNum (I) - File number to set up the entry for.
 534  *   o readable (I) - TRUE if read access to the file.
 535  *   o writable (I) - TRUE if  write access to the file.
 536  * Returns:
 537  *   TCL_OK or TCL_ERROR;
 538  *-----------------------------------------------------------------------------
 539  */
 540 int
 541 Tcl_SetupFileEntry (Tcl_Interp *interp, int fileNum, int readable, int writable)
 542 {
 543     Interp   *iPtr = (Interp *) interp;
 544     char     *mode;
 545     FILE     *fileCBPtr;
 546     OpenFile *filePtr;
 547
 548     /*
 549      * Set up a stdio FILE control block for the new file.
 550      */
 551     if (readable && writable) {
 552         mode = "r+";
 553     } else if (writable) {
 554         mode = "w";
 555     } else {
 556         mode = "r";
 557     }
 558     fileCBPtr = fdopen (fileNum, mode);
 559     if (fileCBPtr == NULL) {
 560         iPtr->result = Tcl_UnixError (interp);
 561         return TCL_ERROR;
 562     }
 563
 564     /*
 565      * Put the file in the Tcl table.
 566      */
 567     TclMakeFileTable (iPtr, fileNum);
 568     if (iPtr->filePtrArray [fileno (fileCBPtr)] != NULL)
 569         panic ("file already open");
 570     filePtr = (OpenFile *) ckalloc (sizeof (OpenFile));
 571     iPtr->filePtrArray [fileno (fileCBPtr)] = filePtr;
 572
 573     filePtr->f        = fileCBPtr;
 574     filePtr->f2       = NULL;
 575     filePtr->readable = readable;
 576     filePtr->writable = writable;
 577     filePtr->numPids  = 0;
 578     filePtr->pidPtr   = NULL;
 579     filePtr->errorId  = -1;
 580
 581     return TCL_OK;
 582 }
 583 \f
 584 /*
 585  *-----------------------------------------------------------------------------
 586  *
 587  * Tcl_System --
 588  *     does the equivalent of the Unix "system" library call, but
 589  *     uses waitpid to wait on the correct process, rather than
 590  *     waiting on all processes and throwing the exit statii away
 591  *     for the processes it isn't interested in, plus does it with
 592  *     a Tcl flavor
 593  *
 594  * Results:
 595  *  Standard TCL results, may return the UNIX system error message.
 596  *
 597  *-----------------------------------------------------------------------------
 598  */
 599 int
 600 Tcl_System (Tcl_Interp *interp, char *command)
 601 {
 602     int processID, waitStatus, processStatus;
 603
 604     if ((processID = Tcl_Fork()) < 0) {
 605         interp->result = Tcl_UnixError (interp);
 606         return -1;
 607     }
 608     if (processID == 0) {
 609         if (execl ("/bin/sh", "sh", "-c", command, (char *) NULL) < 0) {
 610             interp->result = Tcl_UnixError (interp);
 611             return -1;
 612         }
 613         exit(256);
 614     }
 615
 616     /*
 617      * Parent process.
 618      */
 619 #ifndef TCL_HAVE_WAITPID
 620     if (Tcl_WaitPids(1, &processID, &processStatus) == -1) {
 621         interp->result = Tcl_UnixError (interp);
 622         return -1;
 623     }
 624 #else
 625     if (waitpid (processID, &processStatus, 0) == -1) {
 626         interp->result = Tcl_UnixError (interp);
 627         return -1;
 628     }
 629 #endif
 630     return (WEXITSTATUS(processStatus));
 631
 632 }
 633 \f
 634 /*
 635  *--------------------------------------------------------------
 636  *
 637  * Tcl_ReturnDouble --
 638  *
 639  *      Format a double to the maximum precision supported on
 640  *      this machine.  If the number formats to an even integer,
 641  *      a ".0" is append to assure that the value continues to
 642  *      represent a floating point number.
 643  *
 644  * Results:
 645  *      A standard Tcl result.  If the result is TCL_OK, then the
 646  *      interpreter's result is set to the string value of the
 647  *      double.  If the result is TCL_OK, then interp->result
 648  *      contains an error message (If the number had the value of
 649  *      "not a number" or "infinite").
 650  *
 651  * Side effects:
 652  *      None.
 653  *
 654  *--------------------------------------------------------------
 655  */
 656
 657 int
 658 Tcl_ReturnDouble (
 659     Tcl_Interp *interp,                 /* ->result gets converted number */
 660     double number                       /* Number to convert */
 661 )
 662 {
 663     static int precision = 0;
 664     register char *scanPtr;
 665
 666     /*
 667      * On the first call, determine the number of decimal digits that represent
 668      * the precision of a double.
 669      */
 670     if (precision == 0) {
 671 #ifdef IS_LINUX
 672         precision = 8;
 673 #else
 674         sprintf (interp->result, "%.0f", pow (2.0, (double) DSIGNIF));
 675         precision = strlen (interp->result);
 676 #endif
 677     }
 678
 679     sprintf (interp->result, "%.*g", precision, number);
 680
 681     /*
 682      * Scan the number for "." or "e" to assure that the number has not been
 683      * converted to an integer.  Also check for NaN on infinite
 684      */
 685
 686     scanPtr = interp->result;
 687     if (scanPtr [0] == '-')
 688         scanPtr++;
 689     for (; isdigit (*scanPtr); scanPtr++)
 690         continue;
 691
 692     switch (*scanPtr) {
 693       case '.':
 694       case 'e':
 695         return TCL_OK;
 696       case 'n':
 697       case 'N':
 698         interp->result = "Floating point error, result is not a number";
 699         return TCL_ERROR;
 700       case 'i':
 701       case 'I':
 702         interp->result = "Floating point error, result is infinite";
 703         return TCL_ERROR;
 704       case '\0':
 705         scanPtr [0] = '.';
 706         scanPtr [1] = '0';
 707         scanPtr [2] = '\0';
 708         return TCL_OK;
 709     }
 710
 711     /*
 712      * If we made it here, this sprintf returned something we did not expect.
 713      */
 714     Tcl_AppendResult (interp, ": unexpected floating point conversion result",
 715                       (char *) NULL);
 716     return TCL_ERROR;
 717 }
 718