1 2/* 3 * binio.c -- 4 * 5 * Implementation of a binary input and output. 6 * 7 * Copyright (c) Jan 1997, Andreas Kupries (a.kupries@westend.com) 8 * All rights reserved. 9 * 10 * Permission is hereby granted, without written agreement and without 11 * license or royalty fees, to use, copy, modify, and distribute this 12 * software and its documentation for any purpose, provided that the 13 * above copyright notice and the following two paragraphs appear in 14 * all copies of this software. 15 * 16 * IN NO EVENT SHALL I BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, 17 * INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS 18 * SOFTWARE AND ITS DOCUMENTATION, EVEN IF I HAVE BEEN ADVISED OF THE 19 * POSSIBILITY OF SUCH DAMAGE. 20 * 21 * I SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 22 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23 * PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND 24 * I HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, 25 * ENHANCEMENTS, OR MODIFICATIONS. 26 * 27 * CVS: $Id: binio.c,v 1.11 2009/05/07 04:57:27 andreas_kupries Exp $ 28 */ 29 30 31#include "transformInt.h" 32 33#ifdef ENABLE_BINIO 34#include <limits.h> 35 36/* 37 * Forward declarations of internal procedures. 38 */ 39 40static int CopyCmd _ANSI_ARGS_((Tcl_Interp *interp, int argc, char** argv)); 41static int PackCmd _ANSI_ARGS_((Tcl_Interp *interp, int argc, char** argv)); 42static int UnpackCmd _ANSI_ARGS_((Tcl_Interp *interp, int argc, char** argv)); 43static int BinioCmd _ANSI_ARGS_((ClientData notUsed, Tcl_Interp* interp, int argc, char** argv)); 44 45static void ReorderBytes _ANSI_ARGS_ ((char* buf, int len /*2,4,8*/)); 46 47static int GetHex _ANSI_ARGS_ ((Tcl_Interp* interp, char* text, long int* result)); 48static int GetOctal _ANSI_ARGS_ ((Tcl_Interp* interp, char* text, long int* result)); 49 50/* 51 * Return at most this number of bytes in one call to Tcl_Read: 52 */ 53 54#define KILO 1024 55#ifndef READ_CHUNK_SIZE 56#define READ_CHUNK_SIZE (16*KILO) 57#endif 58 59/* 60 * Union to overlay the different possible types used in 'pack', 'unpack'. 61 */ 62 63typedef union { 64 double d; 65 float f; 66 67 long int li; 68 unsigned long ul; 69 70 int i; 71 unsigned int ui; 72 73 short int si; 74 unsigned short us; 75 76 char c; 77 unsigned char uc; 78} conversion; 79 80/* 81 *------------------------------------------------------* 82 * 83 * CopyCmd -- 84 * 85 * ------------------------------------------------* 86 * This procedure realizes the 'binio copy' command. 87 * See the manpages for details on what it does. 88 * ------------------------------------------------* 89 * 90 * Sideeffects: 91 * See user documentation. 92 * 93 * Result: 94 * A standard tcl error code. 95 * 96 *------------------------------------------------------* 97 */ 98 /* ARGSUSED */ 99static int 100CopyCmd (interp, argc, argv) 101Tcl_Interp* interp; /* The interpreter we are working in */ 102int argc; /* # arguments */ 103char** argv; /* trailing arguments */ 104{ 105 /* 106 * Allowed syntax: 107 * inChannel outChannel ?count? 108 * 109 * code taken from 'unsupported0'. 110 */ 111 112 Tcl_Channel inChan, outChan; 113 int requested; 114 char *bufPtr; 115 int actuallyRead, actuallyWritten, totalRead, toReadNow, mode; 116 117 /* 118 * Assume we want to copy the entire channel. 119 */ 120 121 requested = INT_MAX; 122 123 if ((argc < 2) || (argc > 3)) { 124 Tcl_AppendResult(interp, 125 "wrong # args: should be \"binio copy inChannel outChannel ?chunkSize?\"", 126 (char *) NULL); 127 return TCL_ERROR; 128 } 129 130 inChan = Tcl_GetChannel(interp, argv[0], &mode); 131 if (inChan == (Tcl_Channel) NULL) { 132 return TCL_ERROR; 133 } 134 135 if ((mode & TCL_READABLE) == 0) { 136 Tcl_AppendResult(interp, "channel \"", argv[0], 137 "\" wasn't opened for reading", (char *) NULL); 138 return TCL_ERROR; 139 } 140 141 outChan = Tcl_GetChannel(interp, argv[1], &mode); 142 if (outChan == (Tcl_Channel) NULL) { 143 return TCL_ERROR; 144 } 145 146 if ((mode & TCL_WRITABLE) == 0) { 147 Tcl_AppendResult(interp, "channel \"", argv[1], 148 "\" wasn't opened for writing", (char *) NULL); 149 return TCL_ERROR; 150 } 151 152 if (argc == 3) { 153 if (Tcl_GetInt(interp, argv[2], &requested) != TCL_OK) { 154 return TCL_ERROR; 155 } 156 if (requested < 0) { 157 requested = INT_MAX; 158 } 159 } 160 161 bufPtr = ckalloc((unsigned) READ_CHUNK_SIZE); 162 163 for (totalRead = 0; 164 requested > 0; 165 totalRead += actuallyRead, requested -= actuallyRead) { 166 167 toReadNow = requested; 168 if (toReadNow > READ_CHUNK_SIZE) { 169 toReadNow = READ_CHUNK_SIZE; 170 } 171 172 actuallyRead = Tcl_Read(inChan, bufPtr, toReadNow); 173 174 if (actuallyRead < 0) { 175 ckfree (bufPtr); 176 Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(inChan), 177 Tcl_PosixError(interp), (char *) NULL); 178 return TCL_ERROR; 179 } else if (actuallyRead == 0) { 180 ckfree (bufPtr); 181 sprintf(interp->result, "%d", totalRead); 182 return TCL_OK; 183 } 184 185 actuallyWritten = Tcl_Write(outChan, bufPtr, actuallyRead); 186 if (actuallyWritten < 0) { 187 ckfree (bufPtr); 188 Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(outChan), 189 Tcl_PosixError(interp), (char *) NULL); 190 return TCL_ERROR; 191 } 192 } 193 194 ckfree(bufPtr); 195 196 sprintf(interp->result, "%d", totalRead); 197 return TCL_OK; 198} 199 200/* 201 *------------------------------------------------------* 202 * 203 * PackCmd -- 204 * 205 * ------------------------------------------------* 206 * This procedure realizes the 'binio pack' command. 207 * See the manpages for details on what it does. 208 * ------------------------------------------------* 209 * 210 * Sideeffects: 211 * See user documentation. 212 * 213 * Result: 214 * A standard tcl error code. 215 * 216 *------------------------------------------------------* 217 */ 218 /* ARGSUSED */ 219static int 220PackCmd (interp, argc, argv) 221Tcl_Interp* interp; /* The interpreter we are working in */ 222int argc; /* # arguments */ 223char** argv; /* trailing arguments */ 224{ 225 Tcl_Channel outChan; /* The channel to write to */ 226 char* format; 227 conversion cvt; 228 char buffer [50]; 229 char* bufPtr = (char*) NULL; 230 int bufLen = 0; 231 int packed, actuallyWritten, reorder, mode; 232 233 /* 234 * Allowed syntax: 235 * outChannel format ?data1 data2 ...? 236 */ 237 238 if (argc < 2) { 239 Tcl_AppendResult(interp, 240 "wrong # args: should be \"binio pack outChannel format ?data1 data2 ...?\"", 241 (char *) NULL); 242 return TCL_ERROR; 243 } 244 245 outChan = Tcl_GetChannel(interp, argv[0], &mode); 246 if (outChan == (Tcl_Channel) NULL) { 247 return TCL_ERROR; 248 } 249 250 if ((mode & TCL_WRITABLE) == 0) { 251 Tcl_AppendResult(interp, "channel \"", argv[0], 252 "\" wasn't opened for writing", (char *) NULL); 253 return TCL_ERROR; 254 } 255 256 format = argv [1]; 257 argc -= 2; 258 argv += 2; 259 260 for (packed = 0 ; format [0] != '\0'; format += 2, argc --, argv ++, packed ++) { 261 if (format [0] != '%') { 262 char buf [3]; 263 buf [0] = format [0]; 264 buf [1] = format [1]; 265 buf [2] = '\0'; 266 267 Tcl_AppendResult (interp, "unknown format specification '", buf, "'", (char*) NULL); 268 return TCL_ERROR; 269 } 270 271 if (argc == 0) { 272 Tcl_AppendResult (interp, "more format specifiers than data items", (char*) NULL); 273 return TCL_ERROR; 274 } 275 276 reorder = 1; /* prepare for usual case */ 277 278 /* 279 * Possible specifications: 280 * - %d specifies that the corresponding value is a four byte signed int. 281 * - %u specifies that the corresponding value is a four byte unsigned int. 282 * - %o specifies that the corresponding value is a four byte octal signed int. 283 * - %x specifies that the corresponding value is a four byte hexadecimal signed int. 284 * - %l specifies that the corresponding value is an eight byte signed int. 285 * - %L specifies that the corresponding value is an eight byte unsigned int. 286 * - %D specifies that the corresponding value is a two byte signed int. 287 * - %U specifies that the corresponding value is a two byte unsigned int. 288 * - %O specifies that the corresponding value is a two byte octal signed int. 289 * - %X specifies that the corresponding value is a two byte hexadecimal signed int. 290 * - %c specifies that the corresponding value is a one byte signed int (char). 291 * - %C specifies that the corresponding value is a one byte unsigned int. 292 * - %f specifies that the corresponding value is a four byte floating point number. 293 * - %F specifies that the corresponding value is an eight byte floating point number. 294 * - %s specifies that the corresponding value is a NULL terminated string. 295 */ 296 297 switch (format [1]) { 298 case 'd': 299 case 'u': 300 case 'l': 301 case 'L': 302 case 'D': 303 case 'U': 304 case 'c': 305 case 'C': 306 if (TCL_OK != Tcl_GetInt (interp, argv [0], &cvt.i)) { 307 return TCL_ERROR; 308 } 309 310 switch (format [1]) { 311 case 'd': 312 bufPtr = (char*) &cvt.i; 313 bufLen = sizeof (int); 314 break; 315 316 case 'u': 317 cvt.ui = (unsigned int) cvt.i; 318 bufPtr = (char*) &cvt.ui; 319 bufLen = sizeof (unsigned int); 320 break; 321 322 case 'l': 323 cvt.li = (long int) cvt.i; 324 bufPtr = (char*) &cvt.li; 325 bufLen = sizeof (long int); 326 break; 327 328 case 'L': 329 cvt.ul = (unsigned long) cvt.i; 330 bufPtr = (char*) &cvt.ul; 331 bufLen = sizeof (unsigned long); 332 break; 333 334 case 'D': 335 cvt.si = (short int) cvt.i; 336 bufPtr = (char*) &cvt.si; 337 bufLen = sizeof (short int); 338 break; 339 340 case 'U': 341 cvt.us = (short int) cvt.i; 342 bufPtr = (char*) &cvt.us; 343 bufLen = sizeof (unsigned short); 344 break; 345 346 case 'c': 347 cvt.c = (char) cvt.i; 348 bufPtr = (char*) &cvt.c; 349 bufLen = sizeof (char); 350 break; 351 352 case 'C': 353 cvt.uc = (unsigned char) cvt.i; 354 bufPtr = (char*) &cvt.uc; 355 bufLen = sizeof (unsigned char); 356 break; 357 } /* switch */ 358 break; 359 360 case 'o': 361 case 'O': 362 if (TCL_OK != GetOctal (interp, argv [0], &cvt.li)) { 363 return TCL_ERROR; 364 } 365 366 if (format [1] == 'O') { 367 cvt.si = (short int) cvt.i; 368 bufPtr = (char*) &cvt.si; 369 bufLen = sizeof (short int); 370 } else { 371 cvt.i = (int) cvt.li; 372 bufPtr = (char*) &cvt.i; 373 bufLen = sizeof (int); 374 } 375 break; 376 377 case 'x': 378 case 'X': 379 if (TCL_OK != GetHex (interp, argv [0], &cvt.li)) { 380 return TCL_ERROR; 381 } 382 383 if (format [1] == 'X') { 384 cvt.si = (short int) cvt.i; 385 bufPtr = (char*) &cvt.si; 386 bufLen = sizeof (short int); 387 } else { 388 cvt.i = (int) cvt.li; 389 bufPtr = (char*) &cvt.i; 390 bufLen = sizeof (int); 391 } 392 break; 393 394 case 'f': 395 case 'F': 396 if (TCL_OK != Tcl_GetDouble (interp, argv [0], &cvt.d)) { 397 return TCL_ERROR; 398 } 399 400 if (format [1] == 'f') { 401 cvt.f = (float) cvt.d; 402 bufPtr = (char*) &cvt.f; 403 bufLen = sizeof (float); 404 } else { 405 bufPtr = (char*) &cvt.d; 406 bufLen = sizeof (double); 407 } 408 break; 409 410 case 's': 411 bufPtr = argv [0]; 412 bufLen = strlen (argv [0]); 413 reorder = 0; 414 break; 415 } /* switch */ 416 417 418 /* check, wether reordering is required or not. 419 * upon answer `yes` do the reordering here too. 420 */ 421 if ((bufLen > 1) && reorder && 422 (Tcl_GetHostByteorder () != Tcl_GetChannelByteorder (outChan))) { 423 ReorderBytes (bufPtr, bufLen); 424 } 425 426 actuallyWritten = Tcl_Write (outChan, bufPtr, bufLen); 427 if (actuallyWritten < 0) { 428 Tcl_AppendResult(interp, "binio pack: ", Tcl_GetChannelName(outChan), 429 Tcl_PosixError(interp), (char *) NULL); 430 return TCL_ERROR; 431 } 432 } /* for (format) */ 433 434 /* return number of packed items */ 435 sprintf (buffer, "%d", packed); 436 Tcl_AppendResult (interp, buffer, (char*) NULL); 437 return TCL_OK; 438} 439 440/* 441 *------------------------------------------------------* 442 * 443 * UnpackCmd -- 444 * 445 * ------------------------------------------------* 446 * This procedure realizes the 'binio unpack' command. 447 * See the manpages for details on what it does. 448 * ------------------------------------------------* 449 * 450 * Sideeffects: 451 * See user documentation. 452 * 453 * Result: 454 * A standard tcl error code. 455 * 456 *------------------------------------------------------* 457 */ 458 /* ARGSUSED */ 459static int 460UnpackCmd (interp, argc, argv) 461Tcl_Interp* interp; /* The interpreter we are working in */ 462int argc; /* # arguments */ 463char** argv; /* trailing arguments */ 464{ 465 Tcl_Channel inChan; /* The channel to read from */ 466 conversion cvt; 467 int mode, unpacked, actuallyRead; 468 int length; /* length of single item, 469 * < 0 => variable length (string) 470 * 0 is illegal. 471 */ 472 char buffer [50]; /* to hold most of the read information (and its conversion) */ 473 char* format; 474 char* val; 475 476 477 /* 478 * Allowed syntax: 479 * format ?var1 var2 ...? 480 */ 481 482 if (argc < 2) { 483 Tcl_AppendResult(interp, 484 "wrong # args: should be \"binio unpack outChannel format ?var1 var2 ...?\"", 485 (char *) NULL); 486 return TCL_ERROR; 487 } 488 489 inChan = Tcl_GetChannel(interp, argv[0], &mode); 490 if (inChan == (Tcl_Channel) NULL) { 491 return TCL_ERROR; 492 } 493 494 if ((mode & TCL_READABLE) == 0) { 495 Tcl_AppendResult(interp, "channel \"", argv[0], 496 "\" wasn't opened for reading", (char *) NULL); 497 return TCL_ERROR; 498 } 499 500 if (Tcl_Eof (inChan)) { 501 /* 502 * cannot convert behind end of channel. 503 * no error, just unpack nothing ! 504 */ 505 506 Tcl_AppendResult (interp, "0", (char*) NULL); 507 return TCL_OK; 508 } 509 510 format = argv [1]; 511 argc -= 2; 512 argv += 2; 513 514 for (unpacked = 0 ; format [0] != '\0'; format += 2, argc --, argv ++, unpacked ++) { 515 if (format [0] != '%') { 516 char buf [3]; 517 buf [0] = format [0]; 518 buf [1] = format [1]; 519 buf [2] = '\0'; 520 521 Tcl_AppendResult (interp, "unknown format specification '", buf, "'", (char*) NULL); 522 return TCL_ERROR; 523 } 524 525 if (argc == 0) { 526 Tcl_AppendResult (interp, "more format specifiers than variables", (char*) NULL); 527 return TCL_ERROR; 528 } 529 530 length = 0; /* illegal marker, to catch missing cases later */ 531 532 /* 533 * Possible specifications: 534 * - %d specifies that the corresponding value is a four byte signed int. 535 * - %u specifies that the corresponding value is a four byte unsigned int. 536 * - %o specifies that the corresponding value is a four byte octal signed int. 537 * - %x specifies that the corresponding value is a four byte hexadecimal signed int. 538 * - %f specifies that the corresponding value is a four byte floating point number. 539 * 540 * - %l specifies that the corresponding value is an eight byte signed int. 541 * - %L specifies that the corresponding value is an eight byte unsigned int. 542 * - %F specifies that the corresponding value is an eight byte floating point number. 543 * 544 * - %D specifies that the corresponding value is a two byte signed int. 545 * - %U specifies that the corresponding value is a two byte unsigned int. 546 * - %O specifies that the corresponding value is a two byte octal signed int. 547 * - %X specifies that the corresponding value is a two byte hexadecimal signed int. 548 * 549 * - %c specifies that the corresponding value is a one byte signed int (char). 550 * - %C specifies that the corresponding value is a one byte unsigned int. 551 * 552 * - %s specifies that the corresponding value is a NULL terminated string. 553 */ 554 555 /* first: determine number of bytes required, then read these. 556 * at last do the conversion and write into the associated variable. 557 */ 558 559 switch (format [1]) { 560 case 'l': 561 case 'L': 562#if SIZEOF_LONG_INT != 8 563 Tcl_AppendResult (interp, "binio unpack: %l / %L not supported, no 8byte integers here", NULL); 564 return TCL_ERROR; 565#endif 566 case 'F': 567 length = 8; 568 break; 569 570 case 'd': 571 case 'u': 572 case 'o': 573 case 'x': 574 case 'f': 575 length = 4; 576 break; 577 578 case 'D': 579 case 'U': 580 case 'O': 581 case 'X': 582 length = 2; 583 break; 584 585 case 'c': 586 case 'C': 587 length = 1; 588 break; 589 590 case 's': 591 length = -1; /* variable length, string terminated by '\0'. */ 592 break; 593 } 594 595 if (length == 0) { 596 format [2] = '\0'; 597 Tcl_AppendResult (interp, "binio unpack: internal error, missing case for format ", format, NULL); 598 return TCL_ERROR; 599 } else if (length < 0) { 600 /* variable length, string terminated by '\0'. (%s) */ 601 602 Tcl_DString data; 603 Tcl_DStringInit (&data); 604 605 while (! Tcl_Eof (inChan)) { 606 actuallyRead = Tcl_Read (inChan, buffer, 1); 607 608 if (actuallyRead < 0) { 609 Tcl_AppendResult(interp, "binio unpack: ", Tcl_GetChannelName(inChan), 610 Tcl_PosixError(interp), (char *) NULL); 611 return TCL_ERROR; 612 } else if (actuallyRead > 0) { 613 Tcl_DStringAppend (&data, buffer, 1); 614 if (buffer [0] == '\0') { 615 break; 616 } 617 } 618 } /* while */ 619 620 val = Tcl_SetVar (interp, argv [0], data.string, TCL_LEAVE_ERR_MSG); 621 Tcl_DStringFree (&data); 622 623 if (val == NULL) { 624 return TCL_ERROR; 625 } 626 } else { 627 /* handle item with fixed lengths */ 628 629 630 actuallyRead = Tcl_Read (inChan, buffer, length); 631 if (actuallyRead < 0) { 632 Tcl_AppendResult(interp, "binio unpack: ", Tcl_GetChannelName(inChan), 633 Tcl_PosixError(interp), (char *) NULL); 634 return TCL_ERROR; 635 } 636 637 /* check, wether reordering is required or not. 638 * upon answer `yes` do the reordering here too. 639 */ 640 641 if ((length > 1) && 642 (Tcl_GetHostByteorder () != Tcl_GetChannelByteorder (inChan))) { 643 ReorderBytes (buffer, length); 644 } 645 646 switch (format [1]) { 647 case 'd': 648#if SIZEOF_INT == 4 649 /* 'int' is our 4 byte integer on this machine */ 650 memcpy ((VOID*) &cvt.i, (VOID*) buffer, length); 651 sprintf (buffer, "%d", cvt.i); 652#else 653 /* 'int' seems to be equal to 'short' (2 byte), so use 'long int' instead */ 654 memcpy ((VOID*) &cvt.li, (VOID*) buffer, length); 655 sprintf (buffer, "%ld", cvt.li); 656#endif 657 break; 658 659 case 'o': 660#if SIZEOF_INT == 4 661 /* 'int' is our 4 byte integer on this machine */ 662 memcpy ((VOID*) &cvt.i, (VOID*) buffer, length); 663 sprintf (buffer, "%o", cvt.i); 664#else 665 /* 'int' seems to be equal to 'short' (2 byte), so use 'long int' instead */ 666 memcpy ((VOID*) &cvt.li, (VOID*) buffer, length); 667 sprintf (buffer, "%lo", cvt.li); 668#endif 669 break; 670 671 case 'x': 672#if SIZEOF_INT == 4 673 /* 'int' is our 4 byte integer on this machine */ 674 memcpy ((VOID*) &cvt.i, (VOID*) buffer, length); 675 sprintf (buffer, "%08x", cvt.i); 676#else 677 /* 'int' seems to be equal to 'short' (2 byte), so use 'long int' instead */ 678 memcpy ((VOID*) &cvt.li, (VOID*) buffer, length); 679 sprintf (buffer, "%08lx", cvt.li); 680#endif 681 break; 682 683 case 'u': 684#if SIZEOF_INT == 4 685 /* 'unsigned int' is our 4 byte integer on this machine */ 686 memcpy ((VOID*) &cvt.ui, (VOID*) buffer, length); 687 sprintf (buffer, "%u", cvt.ui); 688#else 689 /* 'int' seems to be equal to 'short' (2 byte), so use 'unsigned long' instead */ 690 memcpy ((VOID*) &cvt.ul, (VOID*) buffer, length); 691 sprintf (buffer, "%lu", cvt.ul); 692#endif 693 break; 694 695 case 'D': 696 /* 'short int' is our 2 byte integer on this machine */ 697 memcpy ((VOID*) &cvt.si, (VOID*) buffer, length); 698 sprintf (buffer, "%d", cvt.si); 699 break; 700 701 case 'O': 702 /* 'short int' is our 2 byte integer on this machine */ 703 memcpy ((VOID*) &cvt.si, (VOID*) buffer, length); 704 sprintf (buffer, "%o", cvt.si); 705 break; 706 707 case 'X': 708 /* 'short int' is our 2 byte integer on this machine */ 709 memcpy ((VOID*) &cvt.si, (VOID*) buffer, length); 710 sprintf (buffer, "%04x", cvt.si); 711 break; 712 713 case 'U': 714 /* 'unsigned short' is our 2 byte integer on this machine */ 715 memcpy ((VOID*) &cvt.us, (VOID*) buffer, length); 716 sprintf (buffer, "%u", cvt.us); 717 break; 718 719 case 'l': 720 /* assume SIZEOF_LONG_INT == 8 */ 721 memcpy ((VOID*) &cvt.li, (VOID*) buffer, length); 722 sprintf (buffer, "%ld", cvt.li); 723 break; 724 725 case 'L': 726 /* assume SIZEOF_LONG_INT == 8 */ 727 memcpy ((VOID*) &cvt.ul, (VOID*) buffer, length); 728 sprintf (buffer, "%lu", cvt.ul); 729 break; 730 731 case 'c': 732 memcpy ((VOID*) &cvt.c, (VOID*) buffer, length); 733 cvt.i = cvt.c; 734 sprintf (buffer, "%d", cvt.i); 735 break; 736 737 case 'C': 738 memcpy ((VOID*) &cvt.uc, (VOID*) buffer, length); 739 cvt.ui = cvt.uc; 740 sprintf (buffer, "%u", cvt.ui); 741 break; 742 743 case 'f': 744 memcpy ((VOID*) &cvt.f, (VOID*) buffer, length); 745 sprintf (buffer, "%f", cvt.f); 746 break; 747 748 case 'F': 749 memcpy ((VOID*) &cvt.d, (VOID*) buffer, length); 750 sprintf (buffer, "%f", cvt.d); 751 break; 752 753 case 's': 754 Tcl_AppendResult (interp, "binio unpack: internal error, wrong branch for %s", NULL); 755 return TCL_ERROR; 756 break; 757 } /* switch */ 758 759 val = Tcl_SetVar (interp, argv [0], buffer, TCL_LEAVE_ERR_MSG); 760 if (val == NULL) { 761 return TCL_ERROR; 762 } 763 } /* if (length < 0) */ 764 } /* for (format) */ 765 766 /* return number of unpacked items */ 767 sprintf (buffer, "%d", unpacked); 768 Tcl_AppendResult (interp, buffer, (char*) NULL); 769 return TCL_OK; 770} 771 772/* 773 *------------------------------------------------------* 774 * 775 * ReorderBytes -- 776 * 777 * ------------------------------------------------* 778 * This procedure reorders the bytes in a buffer to 779 * match real and intended byteorder. 780 * ------------------------------------------------* 781 * 782 * Sideeffects: 783 * See above. 784 * 785 * Result: 786 * The incoming buffer 'buf' contains the 787 * reorderd bytes. 788 * 789 *------------------------------------------------------* 790 */ 791 792static void 793ReorderBytes (buf, len) 794char* buf; 795int len; 796{ 797#define FLIP(a,b) c = buf [a]; buf [a] = buf [b]; buf [b] = c; 798 799 char c; 800 801 if (len == 2) { 802 FLIP (0,1); 803 } else if (len == 4) { 804 FLIP (0,3); 805 FLIP (1,2); 806 } else if (len == 8) { 807 FLIP (0,7); 808 FLIP (1,6); 809 FLIP (2,5); 810 FLIP (3,4); 811 } else { 812 Tcl_Panic ("unknown buffer size %d", len); 813 } 814} 815 816/* 817 *------------------------------------------------------* 818 * 819 * GetHex -- 820 * 821 * ------------------------------------------------* 822 * Read a string containing a number in hexadecimal 823 * representation and convert it into a long integer. 824 * ------------------------------------------------* 825 * 826 * Sideeffects: 827 * See above. 828 * 829 * Result: 830 * 'result' contains the conversion result. 831 * A standard tcl error code. 832 * 833 *------------------------------------------------------* 834 */ 835 836static int 837GetHex (interp, text, result) 838Tcl_Interp* interp; 839char* text; 840long int* result; 841{ 842 int match; 843 match = sscanf (text, "%lx", result); 844 845 if (match != 1) { 846 Tcl_AppendResult (interp, "expected hexadecimal integer, but got \"", 847 text, "\"", (char*) NULL); 848 return TCL_ERROR; 849 } 850 851 return TCL_OK; 852} 853 854/* 855 *------------------------------------------------------* 856 * 857 * GetOctal -- 858 * 859 * ------------------------------------------------* 860 * Read a string containing a number in octal 861 * representation and convert it into a long integer. 862 * ------------------------------------------------* 863 * 864 * Sideeffects: 865 * See above. 866 * 867 * Result: 868 * 'result' contains the conversion result. 869 * A standard tcl error code. 870 * 871 *------------------------------------------------------* 872 */ 873 874static int 875GetOctal (interp, text, result) 876Tcl_Interp* interp; 877char* text; 878long int* result; 879{ 880 int match; 881 match = sscanf (text, "%lo", result); 882 883 if (match != 1) { 884 Tcl_AppendResult (interp, "expected octal integer, but got \"", 885 text, "\"", (char*) NULL); 886 return TCL_ERROR; 887 } 888 889 return TCL_OK; 890} 891 892/* 893 *------------------------------------------------------* 894 * 895 * BinioCmd -- 896 * 897 * ------------------------------------------------* 898 * This procedure realizes the 'binio' command. 899 * See the manpages for details on what it does. 900 * ------------------------------------------------* 901 * 902 * Sideeffects: 903 * See the user documentation. 904 * 905 * Result: 906 * A standard Tcl result. 907 * 908 *------------------------------------------------------* 909 */ 910 /* ARGSUSED */ 911static int 912BinioCmd (notUsed, interp, argc, argv) 913ClientData notUsed; /* Not used. */ 914Tcl_Interp* interp; /* Current interpreter. */ 915int argc; /* Number of arguments. */ 916char** argv; /* Argument strings. */ 917{ 918 /* 919 * Allowed syntax: 920 * 921 * binio copy inChannel outChannel ?count? 922 * binio pack outChannel format ?data1 data2 ...? 923 * binio unpack inChannel format ?var1 var2 ...? 924 */ 925 926 int len; 927 char c; 928 Tcl_Channel a; 929 int mode; 930 931 if (argc < 3) { 932 Tcl_AppendResult (interp, 933 "wrong # args: should be \"binio option channel ?arg arg...?\"", 934 (char*) NULL); 935 return TCL_ERROR; 936 } 937 938 c = argv [1][0]; 939 len = strlen (argv [1]); 940 941 a = Tcl_GetChannel (interp, argv [2], &mode); 942 943 if (a == (Tcl_Channel) NULL) { 944 Tcl_ResetResult (interp); 945 Tcl_AppendResult (interp, 946 "binio ", argv [1], 947 ": channel expected as 2nd argument, got \"", 948 argv [2], "\"", (char*) NULL); 949 950 return TCL_ERROR; 951 } 952 953 switch (c) { 954 case 'c': 955 if (0 == strncmp (argv [1], "copy", len)) { 956 return CopyCmd (interp, argc - 2, argv + 2); 957 } else 958 goto unknown_option; 959 break; 960 961 case 'p': 962 if (0 == strncmp (argv [1], "pack", len)) { 963 return PackCmd (interp, argc - 2, argv + 2); 964 } else 965 goto unknown_option; 966 break; 967 968 case 'u': 969 if (0 == strncmp (argv [1], "unpack", len)) { 970 return UnpackCmd (interp, argc - 2, argv + 2); 971 } else 972 goto unknown_option; 973 break; 974 975 default: 976 unknown_option: 977 Tcl_AppendResult (interp, 978 "binio: bad option \"", argv [1], 979 "\": should be one of copy, pack or unpack", 980 (char*) NULL); 981 return TCL_ERROR; 982 } 983 984 return TCL_OK; 985} 986#endif /* ENABLE_BINIO */ 987 988/* 989 *------------------------------------------------------* 990 * 991 * TrfInit_Binio -- 992 * 993 * ------------------------------------------------* 994 * Initializes this command. 995 * ------------------------------------------------* 996 * 997 * Sideeffects: 998 * As of 'Tcl_CreateCommand'. 999 * 1000 * Result: 1001 * A standard Tcl error code. 1002 * 1003 *------------------------------------------------------* 1004 */ 1005 1006int 1007TrfInit_Binio (interp) 1008Tcl_Interp* interp; 1009{ 1010#ifdef ENABLE_BINIO 1011 Tcl_CreateCommand (interp, "binio", BinioCmd, 1012 (ClientData) NULL, 1013 (Tcl_CmdDeleteProc *) NULL); 1014#endif /* ENABLE_BINIO */ 1015 return TCL_OK; 1016} 1017