git.zerfleddert.de Git - micropolis/blob

1 /*

2 * tclXutil.c

3 *

4 * Utility functions for Extended Tcl.

5 *-----------------------------------------------------------------------------

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 */

19 #include "tclxint.h"

21 #ifndef _tolower

22 # define _tolower tolower

23 # define _toupper toupper

24 #endif

26 /*

27 * Used to return argument messages by most commands.

28 */

 char *tclXWrongArgs = "wrong # args: ";

31 extern double pow ();

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

 Tcl_StrToLong (string, base, longPtr)

54 CONST char *string;

55 int base;

56 long *longPtr;

57 {

58 char *end;

59 long num;

     num = strtol(string, &end, base);

     while ((*end != '\0') && isspace(*end)) {

63 end++;

64 }

     if ((end == string) || (*end != 0))

66 return FALSE;

67 *longPtr = num;

68 return TRUE;

70 } /* Tcl_StrToLong */

71 \f

72 /*

73 *-----------------------------------------------------------------------------

74 *

75 * Tcl_StrToInt --

76 * Convert an Ascii string to an number of the specified base.

77 *

78 * Parameters:

79 * o string (I) - String containing a number.

80 * o base (I) - The base to use for the number 8, 10 or 16 or zero to decide

81 * based on the leading characters of the number. Zero to let the number

82 * determine the base.

83 * o intPtr (O) - Place to return the converted number. Will be

84 * unchanged if there is an error.

85 *

86 * Returns:

87 * Returns 1 if the string was a valid number, 0 invalid.

88 *-----------------------------------------------------------------------------

89 */

90 int

 Tcl_StrToInt (string, base, intPtr)

92 CONST char *string;

93 int base;

94 int *intPtr;

95 {

96 char *end;

97 int num;

     num = strtol(string, &end, base);

     while ((*end != '\0') && isspace(*end)) {

101 end++;

102 }

     if ((end == string) || (*end != 0))

104 return FALSE;

105 *intPtr = num;

106 return TRUE;

107

108 } /* Tcl_StrToInt */

109 \f

110 /*

111 *-----------------------------------------------------------------------------

112 *

113 * Tcl_StrToUnsigned --

114 * Convert an Ascii string to an unsigned int of the specified base.

115 *

116 * Parameters:

117 * o string (I) - String containing a number.

118 * o base (I) - The base to use for the number 8, 10 or 16 or zero to decide

119 * based on the leading characters of the number. Zero to let the number

120 * determine the base.

121 * o unsignedPtr (O) - Place to return the converted number. Will be

122 * unchanged if there is an error.

123 *

124 * Returns:

125 * Returns 1 if the string was a valid number, 0 invalid.

126 *-----------------------------------------------------------------------------

127 */

128 int

 Tcl_StrToUnsigned (string, base, unsignedPtr)

130 CONST char *string;

131 int base;

132 unsigned *unsignedPtr;

133 {

134 char *end;

135 unsigned long num;

136

     num = strtoul (string, &end, base);

     while ((*end != '\0') && isspace(*end)) {

139 end++;

140 }

     if ((end == string) || (*end != 0))

142 return FALSE;

143 *unsignedPtr = num;

144 return TRUE;

145

146 } /* Tcl_StrToUnsigned */

147 \f

148 /*

149 *-----------------------------------------------------------------------------

150 *

151 * Tcl_StrToDouble --

152 * Convert a string to a double percision floating point number.

153 *

154 * Parameters:

155 * string (I) - Buffer containing double value to convert.

156 * doublePtr (O) - The convert floating point number.

157 * Returns:

158 * TRUE if the number is ok, FALSE if it is illegal.

159 *-----------------------------------------------------------------------------

160 */

161 int

162 Tcl_StrToDouble (string, doublePtr)

163 CONST char *string;

164 double *doublePtr;

165 {

166 char *end;

167 double num;

168

     num = strtod (string, &end);

     while ((*end != '\0') && isspace(*end)) {

171 end++;

172 }

     if ((end == string) || (*end != 0))

174 return FALSE;

175

176 *doublePtr = num;

177 return TRUE;

178

179 } /* Tcl_StrToDouble */

180 \f

181 /*

182 *-----------------------------------------------------------------------------

183 *

184 * Tcl_DownShift --

185 * Utility procedure to down-shift a string. It is written in such

186 * a way as that the target string maybe the same as the source string.

187 *

188 * Parameters:

189 * o targetStr (I) - String to store the down-shifted string in. Must

190 * have enough space allocated to store the string. If NULL is specified,

191 * then the string will be dynamicly allocated and returned as the

192 * result of the function. May also be the same as the source string to

193 * shift in place.

194 * o sourceStr (I) - The string to down-shift.

195 *

196 * Returns:

197 * A pointer to the down-shifted string

198 *-----------------------------------------------------------------------------

199 */

200 char *

201 Tcl_DownShift (targetStr, sourceStr)

202 char *targetStr;

203 CONST char *sourceStr;

204 {

205 register char theChar;

206

207 if (targetStr == NULL)

         targetStr = ckalloc (strlen ((char *) sourceStr) + 1);

209

     for (; (theChar = *sourceStr) != '\0'; sourceStr++) {

         if (isupper (theChar))

212 theChar = _tolower (theChar);

213 *targetStr++ = theChar;

214 }

215 *targetStr = '\0';

216 return targetStr;

217 }

218 \f

219 /*

220 *-----------------------------------------------------------------------------

221 *

222 * Tcl_UpShift --

223 * Utility procedure to up-shift a string.

224 *

225 * Parameters:

226 * o targetStr (I) - String to store the up-shifted string in. Must

227 * have enough space allocated to store the string. If NULL is specified,

228 * then the string will be dynamicly allocated and returned as the

229 * result of the function. May also be the same as the source string to

230 * shift in place.

231 * o sourceStr (I) - The string to up-shift.

232 *

233 * Returns:

234 * A pointer to the up-shifted string

235 *-----------------------------------------------------------------------------

236 */

237 char *

238 Tcl_UpShift (targetStr, sourceStr)

239 char *targetStr;

240 CONST char *sourceStr;

241 {

242 register char theChar;

243

244 if (targetStr == NULL)

         targetStr = ckalloc (strlen ((char *) sourceStr) + 1);

246

     for (; (theChar = *sourceStr) != '\0'; sourceStr++) {

         if (islower (theChar))

249 theChar = _toupper (theChar);

250 *targetStr++ = theChar;

251 }

252 *targetStr = '\0';

253 return targetStr;

254 }

255 \f

256 /*

257 *-----------------------------------------------------------------------------

258 *

259 * Tcl_ExpandDynBuf --

260 *

261 * Expand a dynamic buffer so that it will have room to hold the

262 * specified additional space. If `appendSize' is zero, the buffer

263 * size will just be doubled.

264 *

265 *-----------------------------------------------------------------------------

266 */

267 void

268 Tcl_ExpandDynBuf (dynBufPtr, appendSize)

269 dynamicBuf_t *dynBufPtr;

270 int appendSize;

271 {

272 int newSize, minSize;

273 char *oldBufPtr;

274

     newSize = dynBufPtr->size * 2;

     minSize = dynBufPtr->len + 1 + appendSize;

277 if (newSize < minSize)

278 newSize = minSize;

279

280 oldBufPtr = dynBufPtr->ptr;

     dynBufPtr->ptr = ckalloc (newSize);

     memcpy (dynBufPtr->ptr, oldBufPtr, dynBufPtr->len + 1);

     if (oldBufPtr != dynBufPtr->buf)

         ckfree ((char *) oldBufPtr);

285 dynBufPtr->size = newSize;

286 }

287 \f

288 /*

289 *-----------------------------------------------------------------------------

290 *

291 * Tcl_DynBufInit --

292 *

293 * Initializes a dynamic buffer.

294 *

295 *-----------------------------------------------------------------------------

296 */

297 void

298 Tcl_DynBufInit (dynBufPtr)

299 dynamicBuf_t *dynBufPtr;

300 {

     dynBufPtr->buf [0] = '\0';

302 dynBufPtr->ptr = dynBufPtr->buf;

303 dynBufPtr->size = INIT_DYN_BUFFER_SIZE;

304 dynBufPtr->len = 0;

305 }

306 \f

307 /*

308 *-----------------------------------------------------------------------------

309 *

310 * Tcl_DynBufFree --

311 *

312 * Clean up a dynamic buffer, release space if it was dynamicly

313 * allocated.

314 *

315 *-----------------------------------------------------------------------------

316 */

317 void

318 Tcl_DynBufFree (dynBufPtr)

319 dynamicBuf_t *dynBufPtr;

320 {

     if (dynBufPtr->ptr != dynBufPtr->buf)

322 ckfree (dynBufPtr->ptr);

323 }

324 \f

325 /*

326 *-----------------------------------------------------------------------------

327 *

328 * Tcl_DynBufReturn --

329 *

330 * Return the contents of the dynamic buffer as an interpreter result.

331 * Don't call DynBufFree after calling this procedure. The dynamic buffer

332 * must be re-initialized to reuse it.

333 *

334 *-----------------------------------------------------------------------------

335 */

336 void

337 Tcl_DynBufReturn (interp, dynBufPtr)

338 Tcl_Interp *interp;

339 dynamicBuf_t *dynBufPtr;

340 {

     if (dynBufPtr->ptr != dynBufPtr->buf)

         Tcl_SetResult (interp, dynBufPtr->ptr, TCL_DYNAMIC);

343 else

         Tcl_SetResult (interp, dynBufPtr->ptr, TCL_VOLATILE);

345 }

346 \f

347 /*

348 *-----------------------------------------------------------------------------

349 *

350 * Tcl_DynBufAppend --

351 *

352 * Append the specified string to the dynamic buffer, expanding if

353 * necessary. Assumes the string in the buffer is zero terminated.

354 *

355 *-----------------------------------------------------------------------------

356 */

357 void

358 Tcl_DynBufAppend (dynBufPtr, newStr)

359 dynamicBuf_t *dynBufPtr;

360 char *newStr;

361 {

362 int newLen, currentUsed;

363

364 newLen = strlen (newStr);

     if ((dynBufPtr->len + newLen + 1) > dynBufPtr->size)

366 Tcl_ExpandDynBuf (dynBufPtr, newLen);

     strcpy (dynBufPtr->ptr + dynBufPtr->len, newStr);

368 dynBufPtr->len += newLen;

369 }

370 \f

371 /*

372 *-----------------------------------------------------------------------------

373 *

374 * Tcl_DynamicFgets --

375 *

376 * Reads a line from a file into a dynamic buffer. The buffer will be

377 * expanded, if necessary and reads are done until EOL or EOF is reached.

378 * Any data already in the buffer will be overwritten. if append is not

379 * specified. Even if an error or EOF is encountered, the buffer should

380 * be cleaned up, as storage may have still been allocated.

381 *

382 * Results:

383 * If data was transfered, returns 1, if EOF was encountered without

384 * transfering any data, returns 0. If an error occured, returns, -1.

385 *

386 *-----------------------------------------------------------------------------

387 */

388 int

 Tcl_DynamicFgets (dynBufPtr, filePtr, append)

390 dynamicBuf_t *dynBufPtr;

391 FILE *filePtr;

392 int append;

393 {

394 int readVal;

395

396 if (!append)

397 dynBufPtr->len = 0;

398

399 while (TRUE) {

         if (dynBufPtr->len + 1 == dynBufPtr->size)

             Tcl_ExpandDynBuf (dynBufPtr, 0);

402

403 readVal = getc (filePtr);

         if (readVal == '\n')      /* Is it a new-line? */

405 break;

         if (readVal == EOF) {     /* Is it an EOF or an error? */

             if (feof (filePtr)) {

408 break;

409 }

             return -1;   /* Error */

411 }

         dynBufPtr->ptr [dynBufPtr->len++] = readVal;

413 }

     dynBufPtr->ptr [dynBufPtr->len] = '\0';

     return (readVal == EOF) ? 0 : 1;

416 }

417 \f

418 /*

419 *-----------------------------------------------------------------------------

420 *

421 * Tcl_GetLong --

422 *

423 * Given a string, produce the corresponding long value.

424 *

425 * Results:

426 * The return value is normally TCL_OK; in this case *intPtr

427 * will be set to the integer value equivalent to string. If

428 * string is improperly formed then TCL_ERROR is returned and

429 * an error message will be left in interp->result.

430 *

431 * Side effects:

432 * None.

433 *

434 *-----------------------------------------------------------------------------

435 */

436 int

 Tcl_GetLong(interp, string, longPtr)

438 Tcl_Interp *interp; /* Interpreter to use for error reporting. */

439 CONST char *string; /* String containing a (possibly signed)

440 * integer in a form acceptable to strtol. */

441 long *longPtr; /* Place to store converted result. */

442 {

443 char *end;

444 long i;

445

     i = strtol(string, &end, 0);

     while ((*end != '\0') && isspace(*end)) {

448 end++;

449 }

     if ((end == string) || (*end != 0)) {

         Tcl_AppendResult (interp, "expected integer but got \"", string,

                           "\"", (char *) NULL);

453 return TCL_ERROR;

454 }

455 *longPtr = i;

456 return TCL_OK;

457 }

458 \f

459 /*

460 *-----------------------------------------------------------------------------

461 *

462 * Tcl_GetUnsigned --

463 *

464 * Given a string, produce the corresponding unsigned integer value.

465 *

466 * Results:

467 * The return value is normally TCL_OK; in this case *intPtr

468 * will be set to the integer value equivalent to string. If

469 * string is improperly formed then TCL_ERROR is returned and

470 * an error message will be left in interp->result.

471 *

472 * Side effects:

473 * None.

474 *

475 *-----------------------------------------------------------------------------

476 */

477 int

 Tcl_GetUnsigned(interp, string, unsignedPtr)

479 Tcl_Interp *interp; /* Interpreter to use for error reporting. */

480 CONST char *string; /* String containing a (possibly signed)

481 * integer in a form acceptable to strtoul. */

482 unsigned *unsignedPtr; /* Place to store converted result. */

483 {

484 char *end;

485 unsigned long i;

486

487 /*

488 * Since some strtoul functions don't detect negative numbers, check

489 * in advance.

490 */

     while (isspace(*string))

492 string++;

     if (string [0] == '-')

494 goto badUnsigned;

495

     i = strtoul(string, &end, 0);

     while ((*end != '\0') && isspace(*end))

498 end++;

499

     if ((end == string) || (*end != '\0'))

501 goto badUnsigned;

502

503 *unsignedPtr = i;

504 return TCL_OK;

505

506 badUnsigned:

     Tcl_AppendResult (interp, "expected unsigned integer but got \"", 

                       string, "\"", (char *) NULL);

509 return TCL_ERROR;

510 }

511 \f

512 /*

513 *-----------------------------------------------------------------------------

514 *

515 * Tcl_ConvertFileHandle --

516 *

517 * Convert a file handle to its file number. The file handle maybe one

518 * of "stdin", "stdout" or "stderr" or "fileNNN", were NNN is the file

519 * number. If the handle is invalid, -1 is returned and a error message

520 * will be returned in interp->result. This is used when the file may

521 * not be currently open.

522 *

523 *-----------------------------------------------------------------------------

524 */

525 int

526 Tcl_ConvertFileHandle (interp, handle)

527 Tcl_Interp *interp;

528 char *handle;

529 {

530 int fileId = -1;

531

     if (handle [0] == 's') {

         if (STREQU (handle, "stdin"))

534 fileId = 0;

         else if (STREQU (handle, "stdout"))

536 fileId = 1;

         else if (STREQU (handle, "stderr"))

538 fileId = 2;

539 } else {

        if (STRNEQU (handle, "file", 4))

            Tcl_StrToInt (&handle [4], 10, &fileId);

542 }

     if (fileId < 0)

         Tcl_AppendResult (interp, "invalid file handle: ", handle,

545 (char *) NULL);

546 return fileId;

547 }

548 \f

549 /*

550 *-----------------------------------------------------------------------------

551 *

552 * Tcl_SetupFileEntry --

553 *

554 * Set up an entry in the Tcl file table for a file number, including the stdio

555 * FILE structure.

556 *

557 * Parameters:

558 * o interp (I) - Current interpreter.

559 * o fileNum (I) - File number to set up the entry for.

560 * o readable (I) - TRUE if read access to the file.

561 * o writable (I) - TRUE if write access to the file.

562 * Returns:

563 * TCL_OK or TCL_ERROR;

564 *-----------------------------------------------------------------------------

565 */

566 int

 Tcl_SetupFileEntry (interp, fileNum, readable, writable)

568 Tcl_Interp *interp;

569 int fileNum;

570 int readable;

571 int writable;

572 {

573 Interp *iPtr = (Interp *) interp;

574 char *mode;

575 FILE *fileCBPtr;

576 OpenFile *filePtr;

577

578 /*

579 * Set up a stdio FILE control block for the new file.

580 */

581 if (readable && writable) {

582 mode = "r+";

583 } else if (writable) {

584 mode = "w";

585 } else {

586 mode = "r";

587 }

     fileCBPtr = fdopen (fileNum, mode);

589 if (fileCBPtr == NULL) {

         iPtr->result = Tcl_UnixError (interp);

591 return TCL_ERROR;

592 }

593

594 /*

595 * Put the file in the Tcl table.

596 */

597 TclMakeFileTable (iPtr, fileNum);

     if (iPtr->filePtrArray [fileno (fileCBPtr)] != NULL)

599 panic ("file already open");

     filePtr = (OpenFile *) ckalloc (sizeof (OpenFile));

     iPtr->filePtrArray [fileno (fileCBPtr)] = filePtr;

602

603 filePtr->f = fileCBPtr;

604 filePtr->f2 = NULL;

605 filePtr->readable = readable;

606 filePtr->writable = writable;

607 filePtr->numPids = 0;

608 filePtr->pidPtr = NULL;

609 filePtr->errorId = -1;

610

611 return TCL_OK;

612 }

613 \f

614 /*

615 *-----------------------------------------------------------------------------

616 *

617 * Tcl_System --

618 * does the equivalent of the Unix "system" library call, but

619 * uses waitpid to wait on the correct process, rather than

620 * waiting on all processes and throwing the exit statii away

621 * for the processes it isn't interested in, plus does it with

622 * a Tcl flavor

623 *

624 * Results:

625 * Standard TCL results, may return the UNIX system error message.

626 *

627 *-----------------------------------------------------------------------------

628 */

629 int

630 Tcl_System (interp, command)

631 Tcl_Interp *interp;

632 char *command;

633 {

634 int processID, waitStatus, processStatus;

635

     if ((processID = Tcl_Fork()) < 0) {

         interp->result = Tcl_UnixError (interp);

638 return -1;

639 }

     if (processID == 0) {

         if (execl ("/bin/sh", "sh", "-c", command, (char *) NULL) < 0) {

             interp->result = Tcl_UnixError (interp);

643 return -1;

644 }

645 exit(256);

646 }

647

648 /*

649 * Parent process.

650 */

651 #ifndef TCL_HAVE_WAITPID

     if (Tcl_WaitPids(1, &processID, &processStatus) == -1) {

         interp->result = Tcl_UnixError (interp);

654 return -1;

655 }

656 #else

     if (waitpid (processID, &processStatus, 0) == -1) {

         interp->result = Tcl_UnixError (interp);

659 return -1;

660 }

661 #endif

     return (WEXITSTATUS(processStatus));

663

664 }

665 \f

666 /*

667 *--------------------------------------------------------------

668 *

669 * Tcl_ReturnDouble --

670 *

671 * Format a double to the maximum precision supported on

672 * this machine. If the number formats to an even integer,

673 * a ".0" is append to assure that the value continues to

674 * represent a floating point number.

675 *

676 * Results:

677 * A standard Tcl result. If the result is TCL_OK, then the

678 * interpreter's result is set to the string value of the

679 * double. If the result is TCL_OK, then interp->result

680 * contains an error message (If the number had the value of

681 * "not a number" or "infinite").

682 *

683 * Side effects:

684 * None.

685 *

686 *--------------------------------------------------------------

687 */

688

689 int

690 Tcl_ReturnDouble(interp, number)

691 Tcl_Interp *interp; /* ->result gets converted number */

692 double number; /* Number to convert */

693 {

694 static int precision = 0;

695 register char *scanPtr;

696

697 /*

698 * On the first call, determine the number of decimal digits that represent

699 * the precision of a double.

700 */

     if (precision == 0) {

702 #ifdef IS_LINUX

703 precision = 8;

704 #else

         sprintf (interp->result, "%.0f", pow (2.0, (double) DSIGNIF));

         precision = strlen (interp->result);

707 #endif

708 }

709

     sprintf (interp->result, "%.*g", precision, number);

711

712 /*

713 * Scan the number for "." or "e" to assure that the number has not been

714 * converted to an integer. Also check for NaN on infinite

715 */

716

717 scanPtr = interp->result;

     if (scanPtr [0] == '-')

719 scanPtr++;

     for (; isdigit (*scanPtr); scanPtr++)

721 continue;

722

723 switch (*scanPtr) {

724 case '.':

725 case 'e':

726 return TCL_OK;

727 case 'n':

728 case 'N':

729 interp->result = "Floating point error, result is not a number";

730 return TCL_ERROR;

731 case 'i':

732 case 'I':

733 interp->result = "Floating point error, result is infinite";

734 return TCL_ERROR;

735 case '\0':

         scanPtr [0] = '.';

         scanPtr [1] = '0';

         scanPtr [2] = '\0';

739 return TCL_OK;

740 }

741

742 /*

743 * If we made it here, this sprintf returned something we did not expect.

744 */

     Tcl_AppendResult (interp, ": unexpected floating point conversion result",

746 (char *) NULL);

747 return TCL_ERROR;

748 }

749