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