Check-in [33876eb1ee]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge updates from HEAD
Timelines: family | ancestors | descendants | both | dgp-refactor
Files: files | file ages | folders
SHA1: 33876eb1ee8c8873889637e4cbd47f108dba27c8
User & Date: dgp 2008-11-17 16:13:45.000
Context
2008-11-18
20:57
merge updates from HEAD check-in: a3661d6d8a user: dgp tags: dgp-refactor
2008-11-17
16:13
merge updates from HEAD check-in: 33876eb1ee user: dgp tags: dgp-refactor
2008-11-10
02:18
merge updates from HEAD check-in: 4a9c1325dc user: dgp tags: dgp-refactor
Changes
Unified Diff Ignore Whitespace Patch
Changes to ChangeLog.














































1
2
3
4
5
6
7














































2008-11-07  Pat Thoyts  <patthoyts@users.sourceforge.net>

	* generic/tclInt.h:    Applied patch #2215022 from Duoas to clean up
	* generic/tclBinary.c: the binary ensemble initiailization code.
	* generic/tclNamesp.c: Extends the TclMakeEnsemble to do
	* doc/ByteArrObj.3:    sub-ensembles from tables.

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
2008-11-17  Alexandre Ferrieux 	<ferrieux@users.sourceforge.net>

	* tests/for.test: Check for uncompiled-for-continue [Bug 2186888]
	fixed earlier.

2008-11-16  Jan Nijtmans  <nijtmans@users.sf.net>

	* generic/tclTest.c:   replace two times Tcl_SetResult with
	                       Tcl_SetObjResult, a little simplification
	                       in preparation for the TIP #340 patch.

2008-11-13  Jan Nijtmans  <nijtmans@users.sf.net>

	* generic/tclInt.h:     rename static function FSUnloadTempFile to
	* generic/tclIOUtil.c   TclFSUnloadTempFile, needed in tclLoad.c

	* generic/tclLoad.c     Fixed [Bug 2269431]: load of shared
	                        objects leaves temporary files on windows

2008-11-12  Pat Thoyts  <patthoyts@users.sourceforge.net>

	* tests/registry.test: Use HKCU to avoid requiring admin access
	for registry testing on vista/server2008

2008-11-11  Jan Nijtmans  <nijtmans@users.sf.net>

	* generic/tclNamesp.c: Eliminate warning: passing arg 4 of
	                       `Tcl_SplitList' from incompatible pointer type
	* win/tcl.m4:       reverted change from 2008-11-06 (was under the
	                    impression that "-Wno-implicit-int" added an
	                    extra warning)
	* win/configure     (regenerated)
	* unix/tcl.m4:      Use -O2 as gcc optimization compiler flag, and get
	                    rid of -Wno-implicit-int for UNIX
	* unix/configure    (regenerated)

2008-11-10  Andreas Kupries  <andreask@activestate.com>

	* doc/platform_shell.n: Fixed [Bug 2255235], reported by Ulrich
	* library/platform/pkgIndex.tcl: Ring <uring@users.sourceforge.net>.
	* library/platform/shell.tcl: Updated the LOCATE command in the
	* library/tm.tcl: package 'platform::shell' to handle the new form
	* unix/Makefile.in: of 'provide' commands generated by tm.tcl. Bumped
	* win/Makefile.in: package to version 1.1.4. Added cross-references
	to the relevant parts of the code to avoid future desynchronization.

2008-11-07  Pat Thoyts  <patthoyts@users.sourceforge.net>

	* generic/tclInt.h:    Applied patch #2215022 from Duoas to clean up
	* generic/tclBinary.c: the binary ensemble initiailization code.
	* generic/tclNamesp.c: Extends the TclMakeEnsemble to do
	* doc/ByteArrObj.3:    sub-ensembles from tables.

Changes to doc/platform_shell.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
'\"
'\" Copyright (c) 2006 ActiveState Software Inc
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: platform_shell.n,v 1.3.2.4 2008/03/26 20:00:00 dgp Exp $
'\" 
.so man.macros
.TH "platform::shell" n 1.1.3 platform::shell "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
platform::shell \- System identification support code and utilities
.SH SYNOPSIS
.nf
\fBpackage require platform::shell ?1.1.3?\fR
.sp
\fBplatform::shell::generic \fIshell\fR
\fBplatform::shell::identify \fIshell\fR
\fBplatform::shell::platform \fIshell\fR
.fi
.BE
.SH DESCRIPTION

|




|


|






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
'\"
'\" Copyright (c) 2006-2008 ActiveState Software Inc
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: platform_shell.n,v 1.3.2.5 2008/11/17 16:13:46 dgp Exp $
'\" 
.so man.macros
.TH "platform::shell" n 1.1.4 platform::shell "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
platform::shell \- System identification support code and utilities
.SH SYNOPSIS
.nf
\fBpackage require platform::shell ?1.1.4?\fR
.sp
\fBplatform::shell::generic \fIshell\fR
\fBplatform::shell::identify \fIshell\fR
\fBplatform::shell::platform \fIshell\fR
.fi
.BE
.SH DESCRIPTION
Changes to generic/tclBinary.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclBinary.c --
 *
 *	This file contains the implementation of the "binary" Tcl built-in
 *	command and the Tcl binary data object.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBinary.c,v 1.13.4.24 2008/11/10 02:18:38 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

#include <math.h>













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclBinary.c --
 *
 *	This file contains the implementation of the "binary" Tcl built-in
 *	command and the Tcl binary data object.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBinary.c,v 1.13.4.25 2008/11/17 16:13:46 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

#include <math.h>

69
70
71
72
73
74
75
76

77
78

79
80
81

82
83

84
85

86
87

88
89

90
91
92
93
94
95
96
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(const void *from, void *to,
			    unsigned length, int type);
/* Binary ensemble commands */
static int		BinaryFormatCmd(ClientData clientData, Tcl_Interp *interp,

			    int objc, Tcl_Obj *const objv[]);
static int		BinaryScanCmd(ClientData clientData, Tcl_Interp *interp,

			    int objc, Tcl_Obj *const objv[]);
/* Binary encoding sub-ensemble commands */
static int		BinaryEncodeHex(ClientData clientData, Tcl_Interp *interp,

			    int objc, Tcl_Obj *const objv[]);
static int		BinaryDecodeHex(ClientData clientData, Tcl_Interp *interp,

			    int objc, Tcl_Obj *const objv[]);
static int		BinaryEncode64(ClientData clientData, Tcl_Interp *interp,

			    int objc, Tcl_Obj *const objv[]);
static int		BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp,

			    int objc, Tcl_Obj *const objv[]);
static int		BinaryDecode64(ClientData clientData, Tcl_Interp *interp,

			    int objc, Tcl_Obj *const objv[]);

/*
 * The following tables are used by the binary encoders
 */

static const char HexDigits[16] = {







|
>

|
>


|
>

|
>

|
>

|
>

|
>







69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(const void *from, void *to,
			    unsigned length, int type);
/* Binary ensemble commands */
static int		BinaryFormatCmd(ClientData clientData,
			    Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		BinaryScanCmd(ClientData clientData,
			    Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
/* Binary encoding sub-ensemble commands */
static int		BinaryEncodeHex(ClientData clientData,
			    Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		BinaryDecodeHex(ClientData clientData,
			    Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		BinaryEncode64(ClientData clientData,
			    Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		BinaryDecodeUu(ClientData clientData,
			    Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		BinaryDecode64(ClientData clientData,
			    Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);

/*
 * The following tables are used by the binary encoders
 */

static const char HexDigits[16] = {
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

230
231
232
233
234
235
236

#define BYTEARRAY_SIZE(len) \
		((unsigned) (sizeof(ByteArray) - 4 + (len)))
#define GET_BYTEARRAY(objPtr) \
		((ByteArray *) (objPtr)->internalRep.otherValuePtr)
#define SET_BYTEARRAY(objPtr, baPtr) \
		(objPtr)->internalRep.otherValuePtr = (void *) (baPtr)


/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewByteArrayObj --
 *
 *	This procedure is creates a new ByteArray object and initializes it
 *	from the given array of bytes.
 *
 * Results:
 *	The newly create object is returned. This object will have no initial
 *	string representation. The returned object has a ref count of 0.
 *
 * Side effects:
 *	Memory allocated for new object and copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewByteArrayObj

Tcl_Obj *
Tcl_NewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length)			/* Length of the array of bytes, which must be
				 * >= 0. */
{

    return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length)			/* Length of the array of bytes, which must be
				 * >= 0. */
{
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */


/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewByteArrayObj --
 *
 *	This procedure is normally called when debugging: i.e., when







<



















<









>

<
<

<
<
<
<
<
<
<
<





<

>







181
182
183
184
185
186
187

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206

207
208
209
210
211
212
213
214
215
216
217


218








219
220
221
222
223

224
225
226
227
228
229
230
231
232

#define BYTEARRAY_SIZE(len) \
		((unsigned) (sizeof(ByteArray) - 4 + (len)))
#define GET_BYTEARRAY(objPtr) \
		((ByteArray *) (objPtr)->internalRep.otherValuePtr)
#define SET_BYTEARRAY(objPtr, baPtr) \
		(objPtr)->internalRep.otherValuePtr = (void *) (baPtr)


/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewByteArrayObj --
 *
 *	This procedure is creates a new ByteArray object and initializes it
 *	from the given array of bytes.
 *
 * Results:
 *	The newly create object is returned. This object will have no initial
 *	string representation. The returned object has a ref count of 0.
 *
 * Side effects:
 *	Memory allocated for new object and copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */


#undef Tcl_NewByteArrayObj

Tcl_Obj *
Tcl_NewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length)			/* Length of the array of bytes, which must be
				 * >= 0. */
{
#ifdef TCL_MEM_DEBUG
    return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);


#else /* if not TCL_MEM_DEBUG */








    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;

#endif /* TCL_MEM_DEBUG */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewByteArrayObj --
 *
 *	This procedure is normally called when debugging: i.e., when
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268

269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292

293
294
295
296
297
298
299
 *
 * Side effects:
 *	Memory allocated for new object and copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length,			/* Length of the array of bytes, which must be
				 * >= 0. */
    const char *file,		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{

    Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length,			/* Length of the array of bytes, which must be
				 * >= 0. */
    const char *file,		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{
    return Tcl_NewByteArrayObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */


/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetByteArrayObj --
 *
 *	Modify an object to be a ByteArray object and to have the specified
 *	array of bytes as its value.







<
<











>





<
<

<
<
<
<
<
<
<
<
<
<
<
<

<

|
>







245
246
247
248
249
250
251


252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268


269












270

271
272
273
274
275
276
277
278
279
280
 *
 * Side effects:
 *	Memory allocated for new object and copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */



Tcl_Obj *
Tcl_DbNewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length,			/* Length of the array of bytes, which must be
				 * >= 0. */
    const char *file,		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{
#ifdef TCL_MEM_DEBUG
    Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;


#else /* if not TCL_MEM_DEBUG */












    return Tcl_NewByteArrayObj(bytes, length);

#endif /* TCL_MEM_DEBUG */
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetByteArrayObj --
 *
 *	Modify an object to be a ByteArray object and to have the specified
 *	array of bytes as its value.
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
    }
    if (objPtr->typePtr != &tclByteArrayType) {
	SetByteArrayFromAny(NULL, objPtr);
    }

    byteArrayPtr = GET_BYTEARRAY(objPtr);
    if (length > byteArrayPtr->allocated) {
	byteArrayPtr = (ByteArray *) ckrealloc(
		(char *) byteArrayPtr, BYTEARRAY_SIZE(length));
	byteArrayPtr->allocated = length;
	SET_BYTEARRAY(objPtr, byteArrayPtr);
    }
    Tcl_InvalidateStringRep(objPtr);
    byteArrayPtr->used = length;
    return byteArrayPtr->bytes;
}







|
|







389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
    }
    if (objPtr->typePtr != &tclByteArrayType) {
	SetByteArrayFromAny(NULL, objPtr);
    }

    byteArrayPtr = GET_BYTEARRAY(objPtr);
    if (length > byteArrayPtr->allocated) {
	byteArrayPtr = (ByteArray *)
		ckrealloc((char *) byteArrayPtr, BYTEARRAY_SIZE(length));
	byteArrayPtr->allocated = length;
	SET_BYTEARRAY(objPtr, byteArrayPtr);
    }
    Tcl_InvalidateStringRep(objPtr);
    byteArrayPtr->used = length;
    return byteArrayPtr->bytes;
}
606
607
608
609
610
611
612
613

614
615
616
617
618
619
620
 * Side effects:
 *	Creates a new binary command as a mapped ensemble.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclInitBinaryCmd(Tcl_Interp *interp)

{
    const EnsembleImplMap binaryMap[] = {
	{ "format", BinaryFormatCmd, NULL },
	{ "scan",   BinaryScanCmd,   NULL },
	{ "encode", NULL,            NULL },
	{ "decode", NULL,            NULL },
	{ NULL, NULL, NULL }







|
>







587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
 * Side effects:
 *	Creates a new binary command as a mapped ensemble.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclInitBinaryCmd(
    Tcl_Interp *interp)
{
    const EnsembleImplMap binaryMap[] = {
	{ "format", BinaryFormatCmd, NULL },
	{ "scan",   BinaryScanCmd,   NULL },
	{ "encode", NULL,            NULL },
	{ "decode", NULL,            NULL },
	{ NULL, NULL, NULL }
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780

781


782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
    while (*format != '\0') {
	str = format;
	flags = 0;
	if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
	    break;
	}
	switch (cmd) {
	    case 'a':
	    case 'A':
	    case 'b':
	    case 'B':
	    case 'h':
	    case 'H':
		/*
		 * For string-type specifiers, the count corresponds to the
		 * number of bytes in a single argument.
		 */

		if (arg >= objc) {
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    Tcl_GetByteArrayFromObj(objv[arg], &count);
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		arg++;
		if (cmd == 'a' || cmd == 'A') {
		    offset += count;
		} else if (cmd == 'b' || cmd == 'B') {
		    offset += (count + 7) / 8;
		} else {
		    offset += (count + 1) / 2;
		}
		break;
	    case 'c':
		size = 1;
		goto doNumbers;
	    case 't':
	    case 's':
	    case 'S':
		size = 2;
		goto doNumbers;
	    case 'n':
	    case 'i':
	    case 'I':
		size = 4;
		goto doNumbers;
	    case 'm':
	    case 'w':
	    case 'W':
		size = 8;
		goto doNumbers;
	    case 'r':
	    case 'R':
	    case 'f':
		size = sizeof(float);
		goto doNumbers;
	    case 'q':
	    case 'Q':
	    case 'd':
		size = sizeof(double);

	    doNumbers:
		if (arg >= objc) {
		    goto badIndex;
		}

		/*
		 * For number-type specifiers, the count corresponds to the
		 * number of elements in the list stored in a single argument.
		 * If no count is specified, then the argument is taken as a
		 * single non-list value.
		 */

		if (count == BINARY_NOCOUNT) {
		    arg++;
		    count = 1;
		} else {
		    int listc;
		    Tcl_Obj **listv;


		    /* The macro evals its args more than once: avoid arg++ */


		    if (TclListObjGetElements(interp, objv[arg], &listc,
			    &listv) != TCL_OK) {
			return TCL_ERROR;
		    }
		    arg++;

		    if (count == BINARY_ALL) {
			count = listc;
		    } else if (count > listc) {
			Tcl_AppendResult(interp,
			    "number of elements in list does not match count",
			    NULL);
			return TCL_ERROR;
		    }
		}
		offset += count*size;
		break;

	    case 'x':
		if (count == BINARY_ALL) {
		    Tcl_AppendResult(interp,
			"cannot use \"*\" in format string with \"x\"",
			NULL);
		    return TCL_ERROR;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		offset += count;
		break;
	    case 'X':
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if ((count > offset) || (count == BINARY_ALL)) {
		    count = offset;
		}
		if (offset > length) {
		    length = offset;
		}
		offset -= count;
		break;
	    case '@':
		if (offset > length) {
		    length = offset;
		}
		if (count == BINARY_ALL) {
		    offset = length;
		} else if (count == BINARY_NOCOUNT) {
		    goto badCount;
		} else {
		    offset = count;
		}
		break;
	    default:
		errorString = str;
		goto badField;
	}
    }
    if (offset > length) {
	length = offset;
    }
    if (length == 0) {
	return TCL_OK;







|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|

>
|
>
>
|
|
|
|
|

|
|
|
|


|
|
|
|
|

|
|
|


|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
    while (*format != '\0') {
	str = format;
	flags = 0;
	if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
	    break;
	}
	switch (cmd) {
	case 'a':
	case 'A':
	case 'b':
	case 'B':
	case 'h':
	case 'H':
	    /*
	     * For string-type specifiers, the count corresponds to the number
	     * of bytes in a single argument.
	     */

	    if (arg >= objc) {
		goto badIndex;
	    }
	    if (count == BINARY_ALL) {
		Tcl_GetByteArrayFromObj(objv[arg], &count);
	    } else if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    arg++;
	    if (cmd == 'a' || cmd == 'A') {
		offset += count;
	    } else if (cmd == 'b' || cmd == 'B') {
		offset += (count + 7) / 8;
	    } else {
		offset += (count + 1) / 2;
	    }
	    break;
	case 'c':
	    size = 1;
	    goto doNumbers;
	case 't':
	case 's':
	case 'S':
	    size = 2;
	    goto doNumbers;
	case 'n':
	case 'i':
	case 'I':
	    size = 4;
	    goto doNumbers;
	case 'm':
	case 'w':
	case 'W':
	    size = 8;
	    goto doNumbers;
	case 'r':
	case 'R':
	case 'f':
	    size = sizeof(float);
	    goto doNumbers;
	case 'q':
	case 'Q':
	case 'd':
	    size = sizeof(double);

	doNumbers:
	    if (arg >= objc) {
		goto badIndex;
	    }

	    /*
	     * For number-type specifiers, the count corresponds to the number
	     * of elements in the list stored in a single argument. If no
	     * count is specified, then the argument is taken as a single
	     * non-list value.
	     */

	    if (count == BINARY_NOCOUNT) {
		arg++;
		count = 1;
	    } else {
		int listc;
		Tcl_Obj **listv;

		/*
		 * The macro evals its args more than once: avoid arg++
		 */

		if (TclListObjGetElements(interp, objv[arg], &listc,
			&listv) != TCL_OK) {
		    return TCL_ERROR;
		}
		arg++;

		if (count == BINARY_ALL) {
		    count = listc;
		} else if (count > listc) {
		    Tcl_AppendResult(interp,
			    "number of elements in list does not match count",
			    NULL);
		    return TCL_ERROR;
		}
	    }
	    offset += count*size;
	    break;

	case 'x':
	    if (count == BINARY_ALL) {
		Tcl_AppendResult(interp,
			"cannot use \"*\" in format string with \"x\"",
			NULL);
		return TCL_ERROR;
	    } else if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    offset += count;
	    break;
	case 'X':
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    if ((count > offset) || (count == BINARY_ALL)) {
		count = offset;
	    }
	    if (offset > length) {
		length = offset;
	    }
	    offset -= count;
	    break;
	case '@':
	    if (offset > length) {
		length = offset;
	    }
	    if (count == BINARY_ALL) {
		offset = length;
	    } else if (count == BINARY_NOCOUNT) {
		goto badCount;
	    } else {
		offset = count;
	    }
	    break;
	default:
	    errorString = str;
	    goto badField;
	}
    }
    if (offset > length) {
	length = offset;
    }
    if (length == 0) {
	return TCL_OK;
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
	if ((count == 0) && (cmd != '@')) {
	    if (cmd != 'x') {
		arg++;
	    }
	    continue;
	}
	switch (cmd) {
	    case 'a':
	    case 'A': {
		char pad = (char) (cmd == 'a' ? '\0' : ' ');
		unsigned char *bytes;

		bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);

		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if (length >= count) {
		    memcpy(cursor, bytes, (size_t) count);
		} else {
		    memcpy(cursor, bytes, (size_t) length);
		    memset(cursor + length, pad, (size_t) (count - length));
		}
		cursor += count;
		break;
	    }
	    case 'b':
	    case 'B': {
		unsigned char *last;

		str = TclGetStringFromObj(objv[arg], &length);
		arg++;
		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		last = cursor + ((count + 7) / 8);
		if (count > length) {
		    count = length;
		}
		value = 0;
		errorString = "binary";
		if (cmd == 'B') {
		    for (offset = 0; offset < count; offset++) {
			value <<= 1;
			if (str[offset] == '1') {
			    value |= 1;
			} else if (str[offset] != '0') {
			    errorValue = str;
			    Tcl_DecrRefCount(resultPtr);
			    goto badValue;
			}
			if (((offset + 1) % 8) == 0) {
			    *cursor++ = UCHAR(value);
			    value = 0;
			}
		    }
		} else {
		    for (offset = 0; offset < count; offset++) {
			value >>= 1;
			if (str[offset] == '1') {
			    value |= 128;
			} else if (str[offset] != '0') {
			    errorValue = str;
			    Tcl_DecrRefCount(resultPtr);
			    goto badValue;
			}
			if (!((offset + 1) % 8)) {
			    *cursor++ = UCHAR(value);
			    value = 0;
			}
		    }
		}
		if ((offset % 8) != 0) {
		    if (cmd == 'B') {
			value <<= 8 - (offset % 8);
		    } else {
			value >>= 8 - (offset % 8);
		    }
		    *cursor++ = UCHAR(value);
		}
		while (cursor < last) {
		    *cursor++ = '\0';
		}
		break;
	    }
	    case 'h':
	    case 'H': {
		unsigned char *last;
		int c;

		str = TclGetStringFromObj(objv[arg], &length);
		arg++;
		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		last = cursor + ((count + 1) / 2);
		if (count > length) {
		    count = length;
		}
		value = 0;
		errorString = "hexadecimal";
		if (cmd == 'H') {
		    for (offset = 0; offset < count; offset++) {
			value <<= 4;
			if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
			    errorValue = str;
			    Tcl_DecrRefCount(resultPtr);
			    goto badValue;
			}
			c = str[offset] - '0';
			if (c > 9) {
			    c += ('0' - 'A') + 10;
			}
			if (c > 16) {
			    c += ('A' - 'a');
			}
			value |= (c & 0xf);
			if (offset % 2) {
			    *cursor++ = (char) value;
			    value = 0;
			}
		    }
		} else {
		    for (offset = 0; offset < count; offset++) {
			value >>= 4;

			if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
			    errorValue = str;
			    Tcl_DecrRefCount(resultPtr);
			    goto badValue;
			}
			c = str[offset] - '0';
			if (c > 9) {
			    c += ('0' - 'A') + 10;
			}
			if (c > 16) {
			    c += ('A' - 'a');
			}
			value |= ((c << 4) & 0xf0);
			if (offset % 2) {
			    *cursor++ = UCHAR(value & 0xff);
			    value = 0;
			}
		    }
		}
		if (offset % 2) {
		    if (cmd == 'H') {
			value <<= 4;
		    } else {
			value >>= 4;
		    }
		    *cursor++ = UCHAR(value);
		}

		while (cursor < last) {
		    *cursor++ = '\0';
		}
		break;
	    }
	    case 'c':
	    case 't':
	    case 's':
	    case 'S':
	    case 'n':
	    case 'i':
	    case 'I':
	    case 'm':
	    case 'w':
	    case 'W':
	    case 'r':
	    case 'R':
	    case 'd':
	    case 'q':
	    case 'Q':
	    case 'f': {
		int listc, i;
		Tcl_Obj **listv;

		if (count == BINARY_NOCOUNT) {
		    /*
		     * Note that we are casting away the const-ness of objv,
		     * but this is safe since we aren't going to modify the
		     * array.
		     */

		    listv = (Tcl_Obj**)(objv + arg);
		    listc = 1;
		    count = 1;
		} else {
		    TclListObjGetElements(interp, objv[arg], &listc, &listv);
		    if (count == BINARY_ALL) {
			count = listc;
		    }
		}
		arg++;
		for (i = 0; i < count; i++) {
		    if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {
			Tcl_DecrRefCount(resultPtr);
			return TCL_ERROR;
		    }
		}
		break;
	    }
	    case 'x':
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		memset(cursor, 0, (size_t) count);
		cursor += count;
		break;
	    case 'X':
		if (cursor > maxPos) {
		    maxPos = cursor;
		}
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
		    cursor = buffer;
		} else {
		    cursor -= count;
		}
		break;
	    case '@':
		if (cursor > maxPos) {
		    maxPos = cursor;
		}
		if (count == BINARY_ALL) {
		    cursor = maxPos;
		} else {
		    cursor = buffer + count;
		}
		break;
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;

 badValue:
    Tcl_ResetResult(interp);







|
|
|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
<
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043

1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
	if ((count == 0) && (cmd != '@')) {
	    if (cmd != 'x') {
		arg++;
	    }
	    continue;
	}
	switch (cmd) {
	case 'a':
	case 'A': {
	    char pad = (char) (cmd == 'a' ? '\0' : ' ');
	    unsigned char *bytes;

	    bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);

	    if (count == BINARY_ALL) {
		count = length;
	    } else if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    if (length >= count) {
		memcpy(cursor, bytes, (size_t) count);
	    } else {
		memcpy(cursor, bytes, (size_t) length);
		memset(cursor + length, pad, (size_t) (count - length));
	    }
	    cursor += count;
	    break;
	}
	case 'b':
	case 'B': {
	    unsigned char *last;

	    str = TclGetStringFromObj(objv[arg], &length);
	    arg++;
	    if (count == BINARY_ALL) {
		count = length;
	    } else if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    last = cursor + ((count + 7) / 8);
	    if (count > length) {
		count = length;
	    }
	    value = 0;
	    errorString = "binary";
	    if (cmd == 'B') {
		for (offset = 0; offset < count; offset++) {
		    value <<= 1;
		    if (str[offset] == '1') {
			value |= 1;
		    } else if (str[offset] != '0') {
			errorValue = str;
			Tcl_DecrRefCount(resultPtr);
			goto badValue;
		    }
		    if (((offset + 1) % 8) == 0) {
			*cursor++ = UCHAR(value);
			value = 0;
		    }
		}
	    } else {
		for (offset = 0; offset < count; offset++) {
		    value >>= 1;
		    if (str[offset] == '1') {
			value |= 128;
		    } else if (str[offset] != '0') {
			errorValue = str;
			Tcl_DecrRefCount(resultPtr);
			goto badValue;
		    }
		    if (!((offset + 1) % 8)) {
			*cursor++ = UCHAR(value);
			value = 0;
		    }
		}
	    }
	    if ((offset % 8) != 0) {
		if (cmd == 'B') {
		    value <<= 8 - (offset % 8);
		} else {
		    value >>= 8 - (offset % 8);
		}
		*cursor++ = UCHAR(value);
	    }
	    while (cursor < last) {
		*cursor++ = '\0';
	    }
	    break;
	}
	case 'h':
	case 'H': {
	    unsigned char *last;
	    int c;

	    str = TclGetStringFromObj(objv[arg], &length);
	    arg++;
	    if (count == BINARY_ALL) {
		count = length;
	    } else if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    last = cursor + ((count + 1) / 2);
	    if (count > length) {
		count = length;
	    }
	    value = 0;
	    errorString = "hexadecimal";
	    if (cmd == 'H') {
		for (offset = 0; offset < count; offset++) {
		    value <<= 4;
		    if (!isxdigit(UCHAR(str[offset]))) {     /* INTL: digit */
			errorValue = str;
			Tcl_DecrRefCount(resultPtr);
			goto badValue;
		    }
		    c = str[offset] - '0';
		    if (c > 9) {
			c += ('0' - 'A') + 10;
		    }
		    if (c > 16) {
			c += ('A' - 'a');
		    }
		    value |= (c & 0xf);
		    if (offset % 2) {
			*cursor++ = (char) value;
			value = 0;
		    }
		}
	    } else {
		for (offset = 0; offset < count; offset++) {
		    value >>= 4;

		    if (!isxdigit(UCHAR(str[offset]))) {     /* INTL: digit */
			errorValue = str;
			Tcl_DecrRefCount(resultPtr);
			goto badValue;
		    }
		    c = str[offset] - '0';
		    if (c > 9) {
			c += ('0' - 'A') + 10;
		    }
		    if (c > 16) {
			c += ('A' - 'a');
		    }
		    value |= ((c << 4) & 0xf0);
		    if (offset % 2) {
			*cursor++ = UCHAR(value & 0xff);
			value = 0;
		    }
		}
	    }
	    if (offset % 2) {
		if (cmd == 'H') {
		    value <<= 4;
		} else {
		    value >>= 4;
		}
		*cursor++ = UCHAR(value);
	    }

	    while (cursor < last) {
		*cursor++ = '\0';
	    }
	    break;
	}
	case 'c':
	case 't':
	case 's':
	case 'S':
	case 'n':
	case 'i':
	case 'I':
	case 'm':
	case 'w':
	case 'W':
	case 'r':
	case 'R':
	case 'd':
	case 'q':
	case 'Q':
	case 'f': {
	    int listc, i;
	    Tcl_Obj **listv;

	    if (count == BINARY_NOCOUNT) {
		/*
		 * Note that we are casting away the const-ness of objv, but
		 * this is safe since we aren't going to modify the array.

		 */

		listv = (Tcl_Obj**)(objv + arg);
		listc = 1;
		count = 1;
	    } else {
		TclListObjGetElements(interp, objv[arg], &listc, &listv);
		if (count == BINARY_ALL) {
		    count = listc;
		}
	    }
	    arg++;
	    for (i = 0; i < count; i++) {
		if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {
		    Tcl_DecrRefCount(resultPtr);
		    return TCL_ERROR;
		}
	    }
	    break;
	}
	case 'x':
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    memset(cursor, 0, (size_t) count);
	    cursor += count;
	    break;
	case 'X':
	    if (cursor > maxPos) {
		maxPos = cursor;
	    }
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
		cursor = buffer;
	    } else {
		cursor -= count;
	    }
	    break;
	case '@':
	    if (cursor > maxPos) {
		maxPos = cursor;
	    }
	    if (count == BINARY_ALL) {
		cursor = maxPos;
	    } else {
		cursor = buffer + count;
	    }
	    break;
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;

 badValue:
    Tcl_ResetResult(interp);
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
    int i;
    Tcl_Obj *valuePtr, *elementPtr;
    Tcl_HashTable numberCacheHash;
    Tcl_HashTable *numberCachePtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,
	    "value formatString ?varName ...?");
	return TCL_ERROR;
    }
    numberCachePtr = &numberCacheHash;
    Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
    buffer = Tcl_GetByteArrayFromObj(objv[1], &length);
    format = TclGetString(objv[2]);
    cursor = buffer;
    arg = 3;
    offset = 0;
    while (*format != '\0') {
	str = format;
	flags = 0;
	if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
	    goto done;
	}
	switch (cmd) {
	    case 'a':
	    case 'A': {
		unsigned char *src;

		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    count = length - offset;
		} else {
		    if (count == BINARY_NOCOUNT) {
			count = 1;
		    }
		    if (count > (length - offset)) {
			goto done;
		    }
		}

		src = buffer + offset;
		size = count;

		/*
		 * Trim trailing nulls and spaces, if necessary.
		 */

		if (cmd == 'A') {
		    while (size > 0) {
			if (src[size-1] != '\0' && src[size-1] != ' ') {
			    break;
			}
			size--;
		    }
		}

		/*
		 * Have to do this #ifdef-fery because (as part of defining
		 * Tcl_NewByteArrayObj) we removed the #def that hides this
		 * stuff normally. If this code ever gets copied to another
		 * file, it should be changed back to the simpler version.
		 */

#ifdef TCL_MEM_DEBUG
		valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__);
#else
		valuePtr = Tcl_NewByteArrayObj(src, size);
#endif /* TCL_MEM_DEBUG */

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
			TCL_LEAVE_ERR_MSG);
		arg++;
		if (resultPtr == NULL) {
		    DeleteScanNumberCache(numberCachePtr);
		    return TCL_ERROR;
		}
		offset += count;
		break;
	    }
	    case 'b':
	    case 'B': {
		unsigned char *src;
		char *dest;

		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    count = (length - offset) * 8;
		} else {
		    if (count == BINARY_NOCOUNT) {
			count = 1;
		    }
		    if (count > (length - offset) * 8) {
			goto done;
		    }
		}
		src = buffer + offset;
		valuePtr = Tcl_NewObj();
		Tcl_SetObjLength(valuePtr, count);
		dest = TclGetString(valuePtr);

		if (cmd == 'b') {
		    for (i = 0; i < count; i++) {
			if (i % 8) {
			    value >>= 1;
			} else {
			    value = *src++;
			}
			*dest++ = (char) ((value & 1) ? '1' : '0');
		    }
		} else {
		    for (i = 0; i < count; i++) {
			if (i % 8) {
			    value <<= 1;
			} else {
			    value = *src++;
			}
			*dest++ = (char) ((value & 0x80) ? '1' : '0');
		    }
		}

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
			TCL_LEAVE_ERR_MSG);
		arg++;
		if (resultPtr == NULL) {
		    DeleteScanNumberCache(numberCachePtr);
		    return TCL_ERROR;
		}
		offset += (count + 7) / 8;
		break;
	    }
	    case 'h':
	    case 'H': {
		char *dest;
		unsigned char *src;
		int i;
		static const char hexdigit[] = "0123456789abcdef";

		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    count = (length - offset)*2;
		} else {
		    if (count == BINARY_NOCOUNT) {
			count = 1;
		    }
		    if (count > (length - offset)*2) {
			goto done;
		    }
		}
		src = buffer + offset;
		valuePtr = Tcl_NewObj();
		Tcl_SetObjLength(valuePtr, count);
		dest = TclGetString(valuePtr);

		if (cmd == 'h') {
		    for (i = 0; i < count; i++) {
			if (i % 2) {
			    value >>= 4;
			} else {
			    value = *src++;
			}
			*dest++ = hexdigit[value & 0xf];
		    }
		} else {
		    for (i = 0; i < count; i++) {
			if (i % 2) {
			    value <<= 4;
			} else {
			    value = *src++;
			}
			*dest++ = hexdigit[(value >> 4) & 0xf];
		    }
		}

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
			TCL_LEAVE_ERR_MSG);
		arg++;
		if (resultPtr == NULL) {
		    DeleteScanNumberCache(numberCachePtr);
		    return TCL_ERROR;
		}
		offset += (count + 1) / 2;
		break;
	    }
	    case 'c':
		size = 1;
		goto scanNumber;
	    case 't':
	    case 's':
	    case 'S':
		size = 2;
		goto scanNumber;
	    case 'n':
	    case 'i':
	    case 'I':
		size = 4;
		goto scanNumber;
	    case 'm':
	    case 'w':
	    case 'W':
		size = 8;
		goto scanNumber;
	    case 'r':
	    case 'R':
	    case 'f':
		size = sizeof(float);
		goto scanNumber;
	    case 'q':
	    case 'Q':
	    case 'd': {
		unsigned char *src;

		size = sizeof(double);
		/* fall through */

	    scanNumber:
		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_NOCOUNT) {
		    if ((length - offset) < size) {
			goto done;
		    }
		    valuePtr = ScanNumber(buffer+offset, cmd, flags,
			    &numberCachePtr);
		    offset += size;
		} else {
		    if (count == BINARY_ALL) {
			count = (length - offset) / size;
		    }
		    if ((length - offset) < (count * size)) {
			goto done;
		    }
		    valuePtr = Tcl_NewObj();
		    src = buffer+offset;
		    for (i = 0; i < count; i++) {
			elementPtr = ScanNumber(src, cmd, flags,
				&numberCachePtr);
			src += size;
			Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
		    }
		    offset += count*size;
		}

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
			TCL_LEAVE_ERR_MSG);
		arg++;
		if (resultPtr == NULL) {
		    DeleteScanNumberCache(numberCachePtr);
		    return TCL_ERROR;
		}
		break;
	    }
	    case 'x':
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if ((count == BINARY_ALL) || (count > (length - offset))) {
		    offset = length;
		} else {
		    offset += count;
		}
		break;
	    case 'X':
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if ((count == BINARY_ALL) || (count > offset)) {
		    offset = 0;
		} else {
		    offset -= count;
		}
		break;
	    case '@':
		if (count == BINARY_NOCOUNT) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badCount;
		}
		if ((count == BINARY_ALL) || (count > length)) {
		    offset = length;
		} else {
		    offset = count;
		}
		break;
	    default:
		DeleteScanNumberCache(numberCachePtr);
		errorString = str;
		goto badField;
	}
    }

    /*
     * Set the result to the last position of the cursor.
     */








|
















|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
|
|

|
|
|
|
|
|
|
|

|
|
|
|
|
|


|

|


|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413

1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
    int i;
    Tcl_Obj *valuePtr, *elementPtr;
    Tcl_HashTable numberCacheHash;
    Tcl_HashTable *numberCachePtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"value formatString ?varName ...?");
	return TCL_ERROR;
    }
    numberCachePtr = &numberCacheHash;
    Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
    buffer = Tcl_GetByteArrayFromObj(objv[1], &length);
    format = TclGetString(objv[2]);
    cursor = buffer;
    arg = 3;
    offset = 0;
    while (*format != '\0') {
	str = format;
	flags = 0;
	if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
	    goto done;
	}
	switch (cmd) {
	case 'a':
	case 'A': {
	    unsigned char *src;

	    if (arg >= objc) {
		DeleteScanNumberCache(numberCachePtr);
		goto badIndex;
	    }
	    if (count == BINARY_ALL) {
		count = length - offset;
	    } else {
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if (count > (length - offset)) {
		    goto done;
		}
	    }

	    src = buffer + offset;
	    size = count;

	    /*
	     * Trim trailing nulls and spaces, if necessary.
	     */

	    if (cmd == 'A') {
		while (size > 0) {
		    if (src[size-1] != '\0' && src[size-1] != ' ') {
			break;
		    }
		    size--;
		}
	    }

	    /*
	     * Have to do this #ifdef-fery because (as part of defining
	     * Tcl_NewByteArrayObj) we removed the #def that hides this stuff
	     * normally. If this code ever gets copied to another file, it
	     * should be changed back to the simpler version.
	     */

#ifdef TCL_MEM_DEBUG
	    valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__, __LINE__);
#else
	    valuePtr = Tcl_NewByteArrayObj(src, size);
#endif /* TCL_MEM_DEBUG */

	    resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
		    TCL_LEAVE_ERR_MSG);
	    arg++;
	    if (resultPtr == NULL) {
		DeleteScanNumberCache(numberCachePtr);
		return TCL_ERROR;
	    }
	    offset += count;
	    break;
	}
	case 'b':
	case 'B': {
	    unsigned char *src;
	    char *dest;

	    if (arg >= objc) {
		DeleteScanNumberCache(numberCachePtr);
		goto badIndex;
	    }
	    if (count == BINARY_ALL) {
		count = (length - offset) * 8;
	    } else {
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if (count > (length - offset) * 8) {
		    goto done;
		}
	    }
	    src = buffer + offset;
	    valuePtr = Tcl_NewObj();
	    Tcl_SetObjLength(valuePtr, count);
	    dest = TclGetString(valuePtr);

	    if (cmd == 'b') {
		for (i = 0; i < count; i++) {
		    if (i % 8) {
			value >>= 1;
		    } else {
			value = *src++;
		    }
		    *dest++ = (char) ((value & 1) ? '1' : '0');
		}
	    } else {
		for (i = 0; i < count; i++) {
		    if (i % 8) {
			value <<= 1;
		    } else {
			value = *src++;
		    }
		    *dest++ = (char) ((value & 0x80) ? '1' : '0');
		}
	    }

	    resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
		    TCL_LEAVE_ERR_MSG);
	    arg++;
	    if (resultPtr == NULL) {
		DeleteScanNumberCache(numberCachePtr);
		return TCL_ERROR;
	    }
	    offset += (count + 7) / 8;
	    break;
	}
	case 'h':
	case 'H': {
	    char *dest;
	    unsigned char *src;
	    int i;
	    static const char hexdigit[] = "0123456789abcdef";

	    if (arg >= objc) {
		DeleteScanNumberCache(numberCachePtr);
		goto badIndex;
	    }
	    if (count == BINARY_ALL) {
		count = (length - offset)*2;
	    } else {
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if (count > (length - offset)*2) {
		    goto done;
		}
	    }
	    src = buffer + offset;
	    valuePtr = Tcl_NewObj();
	    Tcl_SetObjLength(valuePtr, count);
	    dest = TclGetString(valuePtr);

	    if (cmd == 'h') {
		for (i = 0; i < count; i++) {
		    if (i % 2) {
			value >>= 4;
		    } else {
			value = *src++;
		    }
		    *dest++ = hexdigit[value & 0xf];
		}
	    } else {
		for (i = 0; i < count; i++) {
		    if (i % 2) {
			value <<= 4;
		    } else {
			value = *src++;
		    }
		    *dest++ = hexdigit[(value >> 4) & 0xf];
		}
	    }

	    resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
		    TCL_LEAVE_ERR_MSG);
	    arg++;
	    if (resultPtr == NULL) {
		DeleteScanNumberCache(numberCachePtr);
		return TCL_ERROR;
	    }
	    offset += (count + 1) / 2;
	    break;
	}
	case 'c':
	    size = 1;
	    goto scanNumber;
	case 't':
	case 's':
	case 'S':
	    size = 2;
	    goto scanNumber;
	case 'n':
	case 'i':
	case 'I':
	    size = 4;
	    goto scanNumber;
	case 'm':
	case 'w':
	case 'W':
	    size = 8;
	    goto scanNumber;
	case 'r':
	case 'R':
	case 'f':
	    size = sizeof(float);
	    goto scanNumber;
	case 'q':
	case 'Q':
	case 'd': {
	    unsigned char *src;

	    size = sizeof(double);
	    /* fall through */

	scanNumber:
	    if (arg >= objc) {
		DeleteScanNumberCache(numberCachePtr);
		goto badIndex;
	    }
	    if (count == BINARY_NOCOUNT) {
		if ((length - offset) < size) {
		    goto done;
		}
		valuePtr = ScanNumber(buffer+offset, cmd, flags,
			&numberCachePtr);
		offset += size;
	    } else {
		if (count == BINARY_ALL) {
		    count = (length - offset) / size;
		}
		if ((length - offset) < (count * size)) {
		    goto done;
		}
		valuePtr = Tcl_NewObj();
		src = buffer + offset;
		for (i = 0; i < count; i++) {
		    elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr);

		    src += size;
		    Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
		}
		offset += count * size;
	    }

	    resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
		    TCL_LEAVE_ERR_MSG);
	    arg++;
	    if (resultPtr == NULL) {
		DeleteScanNumberCache(numberCachePtr);
		return TCL_ERROR;
	    }
	    break;
	}
	case 'x':
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    if ((count == BINARY_ALL) || (count > (length - offset))) {
		offset = length;
	    } else {
		offset += count;
	    }
	    break;
	case 'X':
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    if ((count == BINARY_ALL) || (count > offset)) {
		offset = 0;
	    } else {
		offset -= count;
	    }
	    break;
	case '@':
	    if (count == BINARY_NOCOUNT) {
		DeleteScanNumberCache(numberCachePtr);
		goto badCount;
	    }
	    if ((count == BINARY_ALL) || (count > length)) {
		offset = length;
	    } else {
		offset = count;
	    }
	    break;
	default:
	    DeleteScanNumberCache(numberCachePtr);
	    errorString = str;
	    goto badField;
	}
    }

    /*
     * Set the result to the last position of the cursor.
     */

1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
     * Extract the command character and any trailing digits or '*'.
     */

    *cmdPtr = **formatPtr;
    (*formatPtr)++;
    if (**formatPtr == 'u') {
	(*formatPtr)++;
	(*flagsPtr) |= BINARY_UNSIGNED;
    }
    if (**formatPtr == '*') {
	(*formatPtr)++;
	(*countPtr) = BINARY_ALL;
    } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
	(*countPtr) = strtoul(*formatPtr, formatPtr, 10);
    } else {
	(*countPtr) = BINARY_NOCOUNT;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *







|



|

|

|







1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
     * Extract the command character and any trailing digits or '*'.
     */

    *cmdPtr = **formatPtr;
    (*formatPtr)++;
    if (**formatPtr == 'u') {
	(*formatPtr)++;
	*flagsPtr |= BINARY_UNSIGNED;
    }
    if (**formatPtr == '*') {
	(*formatPtr)++;
	*countPtr = BINARY_ALL;
    } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
	*countPtr = strtoul(*formatPtr, formatPtr, 10);
    } else {
	*countPtr = BINARY_NOCOUNT;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
Changes to generic/tclIOUtil.c.
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.81.2.42 2008/10/11 03:37:27 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"







|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.81.2.43 2008/11/17 16:13:46 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
static Tcl_Obj *cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)

Tcl_ThreadDataKey tclFsDataKey;

/*
 * Declare fallback support function and information for Tcl_FSLoadFile
 */

static Tcl_FSUnloadFileProc	FSUnloadTempFile;

/*
 * One of these structures is used each time we successfully load a file from
 * a file system by way of making a temporary copy of the file on the native
 * filesystem. We need to store both the actual unloadProc/clientData
 * combination which was used, and the original and modified filenames, so
 * that we can correctly undo the entire operation when we want to unload the
 * code.







<
<
<
<
<
<







187
188
189
190
191
192
193






194
195
196
197
198
199
200
static Tcl_Obj *cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)

Tcl_ThreadDataKey tclFsDataKey;







/*
 * One of these structures is used each time we successfully load a file from
 * a file system by way of making a temporary copy of the file on the native
 * filesystem. We need to store both the actual unloadProc/clientData
 * combination which was used, and the original and modified filenames, so
 * that we can correctly undo the entire operation when we want to unload the
 * code.
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
	tvdlPtr->divertedFilesystem = NULL;
	Tcl_DecrRefCount(copyToPtr);
    }

    copyToPtr = NULL;
    *handlePtr = newLoadHandle;
    *clientDataPtr = tvdlPtr;
    *unloadProcPtr = &FSUnloadTempFile;

    Tcl_ResetResult(interp);
    return retVal;

  resolveSymbols:
    {
	int i;







|







3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
	tvdlPtr->divertedFilesystem = NULL;
	Tcl_DecrRefCount(copyToPtr);
    }

    copyToPtr = NULL;
    *handlePtr = newLoadHandle;
    *clientDataPtr = tvdlPtr;
    *unloadProcPtr = TclFSUnloadTempFile;

    Tcl_ResetResult(interp);
    return retVal;

  resolveSymbols:
    {
	int i;
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
    *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * FSUnloadTempFile --
 *
 *	This function is called when we loaded a library of code via an
 *	intermediate temporary file. This function ensures the library is
 *	correctly unloaded and the temporary file is correctly deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The effects of the 'unload' function called, and of course the
 *	temporary file will be deleted.
 *
 *---------------------------------------------------------------------------
 */

static void
FSUnloadTempFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * Tcl_FSLoadFile(). The loadHandle is a token
				 * that represents the loaded file. */
{
    FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle;

    /*







|















|
|







3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
    *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSUnloadTempFile --
 *
 *	This function is called when we loaded a library of code via an
 *	intermediate temporary file. This function ensures the library is
 *	correctly unloaded and the temporary file is correctly deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The effects of the 'unload' function called, and of course the
 *	temporary file will be deleted.
 *
 *---------------------------------------------------------------------------
 */

void
TclFSUnloadTempFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * Tcl_FSLoadFile(). The loadHandle is a token
				 * that represents the loaded file. */
{
    FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle;

    /*
Changes to generic/tclInt.h.
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 * Copyright (c) 2008 by Miguel Sofer. All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.127.2.95 2008/11/10 02:18:39 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options







|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 * Copyright (c) 2008 by Miguel Sofer. All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.127.2.96 2008/11/17 16:13:46 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
2717
2718
2719
2720
2721
2722
2723

2724
2725
2726
2727
2728
2729
2730
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadAlloc(void);
MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE double	TclFloor(mp_int *a);
MODULE_SCOPE void	TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    const char *attributeName, int *indexPtr);

MODULE_SCOPE int *	TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetChannelFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
			    int *modePtr, int flags);
MODULE_SCOPE int	TclGetNumberFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, ClientData *clientDataPtr,







>







2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadAlloc(void);
MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE double	TclFloor(mp_int *a);
MODULE_SCOPE void	TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    const char *attributeName, int *indexPtr);
MODULE_SCOPE void	TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
MODULE_SCOPE int *	TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetChannelFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
			    int *modePtr, int flags);
MODULE_SCOPE int	TclGetNumberFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, ClientData *clientDataPtr,
Changes to generic/tclLoad.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same on all
 *	platforms) of Tcl's dynamic loading facilities.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoad.c,v 1.9.4.9 2008/10/17 20:52:24 dgp Exp $
 */

#include "tclInt.h"

/*
 * The following structure describes a package that has been loaded either
 * dynamically (with the "load" command) or statically (as indicated by a call











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same on all
 *	platforms) of Tcl's dynamic loading facilities.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoad.c,v 1.9.4.10 2008/11/17 16:13:46 dgp Exp $
 */

#include "tclInt.h"

/*
 * The following structure describes a package that has been loaded either
 * dynamically (with the "load" command) or statically (as indicated by a call
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
	 */

	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;

	    if (unLoadProcPtr != NULL) {
		Tcl_MutexLock(&packageMutex);
		if (pkgPtr->unloadProc != NULL) {
		    unLoadProcPtr(pkgPtr->loadHandle);
		}

		/*
		 * Remove this library from the loaded library cache.
		 */








|







787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
	 */

	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;

	    if (unLoadProcPtr != NULL) {
		Tcl_MutexLock(&packageMutex);
		if ((pkgPtr->unloadProc != NULL) || (unLoadProcPtr == TclFSUnloadTempFile)) {
		    unLoadProcPtr(pkgPtr->loadHandle);
		}

		/*
		 * Remove this library from the loaded library cache.
		 */

1142
1143
1144
1145
1146
1147
1148


1149

1150
1151
1152
1153
1154
1155
1156
1157
	 * Some Unix dlls are poorly behaved - registering things like atexit
	 * calls that can't be unregistered. If you unload such dlls, you get
	 * a core on exit because it wants to call a function in the dll after
	 * it has been unloaded.
	 */

	if (pkgPtr->fileName[0] != '\0') {


	    if ((pkgPtr->unLoadProcPtr != NULL) && (pkgPtr->unloadProc != NULL)) {

		pkgPtr->unLoadProcPtr(pkgPtr->loadHandle);
	    }
	}
#endif

	ckfree(pkgPtr->fileName);
	ckfree(pkgPtr->packageName);
	ckfree((char *) pkgPtr);







>
>
|
>
|







1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
	 * Some Unix dlls are poorly behaved - registering things like atexit
	 * calls that can't be unregistered. If you unload such dlls, you get
	 * a core on exit because it wants to call a function in the dll after
	 * it has been unloaded.
	 */

	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
	    if ((unLoadProcPtr != NULL)
		    && ((pkgPtr->unloadProc != NULL)
		    || (unLoadProcPtr == TclFSUnloadTempFile))) {
		unLoadProcPtr(pkgPtr->loadHandle);
	    }
	}
#endif

	ckfree(pkgPtr->fileName);
	ckfree(pkgPtr->packageName);
	ckfree((char *) pkgPtr);
Changes to generic/tclNamesp.c.
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   mmclennan@lucent.com
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.31.4.56 2008/11/10 02:18:39 dgp Exp $
 */

#include "tclInt.h"

/*
 * Thread-local storage used to avoid having a global lock on data that is not
 * limited to a single interpreter.







|







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   mmclennan@lucent.com
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.31.4.57 2008/11/17 16:13:46 dgp Exp $
 */

#include "tclInt.h"

/*
 * Thread-local storage used to avoid having a global lock on data that is not
 * limited to a single interpreter.
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
    Tcl_Interp *interp,
    const char *name,		 /* The ensemble name (as explained above) */
    const EnsembleImplMap map[]) /* The subcommands to create */
{
    Tcl_Command ensemble;
    Tcl_Namespace *ns;
    Tcl_DString buf;
    char **nameParts;
    const char *cmdname;
    int i, nameCount = 0, ensembleFlags = 0;

    /*
     * Construct the path for the ensemble namespace and create it
     */
    
    Tcl_DStringInit(&buf);
    Tcl_DStringAppend(&buf, "::tcl", -1);
    
    if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
	Tcl_Panic("invalid ensemble name '%s'", name);
    }

    for (i = 0; i < nameCount; ++i) {
	Tcl_DStringAppend(&buf, "::", 2);
	Tcl_DStringAppend(&buf, nameParts[i], -1);
    }
    
    ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf),
	NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (!ns) {
	Tcl_Panic("unable to find or create %s namespace!",
	    Tcl_DStringValue(&buf));
    }

    /*
     * Create the named ensemble in the correct namespace
     */
    
    if (nameCount == 1) {
	ensembleFlags = TCL_ENSEMBLE_PREFIX;
	cmdname = Tcl_DStringValue(&buf) + 5;
    } else {
	ns = ns->parentPtr;
	cmdname = nameParts[nameCount - 1];
    }







|






|


|








|










|







6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
    Tcl_Interp *interp,
    const char *name,		 /* The ensemble name (as explained above) */
    const EnsembleImplMap map[]) /* The subcommands to create */
{
    Tcl_Command ensemble;
    Tcl_Namespace *ns;
    Tcl_DString buf;
    const char **nameParts;
    const char *cmdname;
    int i, nameCount = 0, ensembleFlags = 0;

    /*
     * Construct the path for the ensemble namespace and create it
     */

    Tcl_DStringInit(&buf);
    Tcl_DStringAppend(&buf, "::tcl", -1);

    if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
	Tcl_Panic("invalid ensemble name '%s'", name);
    }

    for (i = 0; i < nameCount; ++i) {
	Tcl_DStringAppend(&buf, "::", 2);
	Tcl_DStringAppend(&buf, nameParts[i], -1);
    }

    ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf),
	NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (!ns) {
	Tcl_Panic("unable to find or create %s namespace!",
	    Tcl_DStringValue(&buf));
    }

    /*
     * Create the named ensemble in the correct namespace
     */

    if (nameCount == 1) {
	ensembleFlags = TCL_ENSEMBLE_PREFIX;
	cmdname = Tcl_DStringValue(&buf) + 5;
    } else {
	ns = ns->parentPtr;
	cmdname = nameParts[nameCount - 1];
    }
Changes to generic/tclTest.c.
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Copyright (c) 2003 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTest.c,v 1.67.2.40 2008/10/17 20:52:25 dgp Exp $
 */

#define TCL_TEST
#include "tclInt.h"

/*
 * Required for Testregexp*Cmd







|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Copyright (c) 2003 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTest.c,v 1.67.2.41 2008/11/17 16:13:46 dgp Exp $
 */

#define TCL_TEST
#include "tclInt.h"

/*
 * Required for Testregexp*Cmd
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
TestFilesystemObjCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int res, boolVal;
    char *msg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "boolean");
	return TCL_ERROR;
    }
    if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
	return TCL_ERROR;
    }
    if (boolVal) {
	res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
	msg = (res == TCL_OK) ? "registered" : "failed";
    } else {
	res = Tcl_FSUnregister(&testReportingFilesystem);
	msg = (res == TCL_OK) ? "unregistered" : "failed";
    }
    Tcl_SetResult(interp, msg, TCL_VOLATILE);
    return res;
}

static int
TestReportInFilesystem(
    Tcl_Obj *pathPtr,
    ClientData *clientDataPtr)







|















|







5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
TestFilesystemObjCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int res, boolVal;
    const char *msg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "boolean");
	return TCL_ERROR;
    }
    if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
	return TCL_ERROR;
    }
    if (boolVal) {
	res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
	msg = (res == TCL_OK) ? "registered" : "failed";
    } else {
	res = Tcl_FSUnregister(&testReportingFilesystem);
	msg = (res == TCL_OK) ? "unregistered" : "failed";
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
    return res;
}

static int
TestReportInFilesystem(
    Tcl_Obj *pathPtr,
    ClientData *clientDataPtr)
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
TestSimpleFilesystemObjCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int res, boolVal;
    char *msg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "boolean");
	return TCL_ERROR;
    }
    if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
	return TCL_ERROR;
    }
    if (boolVal) {
	res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
	msg = (res == TCL_OK) ? "registered" : "failed";
    } else {
	res = Tcl_FSUnregister(&simpleFilesystem);
	msg = (res == TCL_OK) ? "unregistered" : "failed";
    }
    Tcl_SetResult(interp, msg, TCL_VOLATILE);
    return res;
}

/*
 * Treats a file name 'simplefs:/foo' by using the file 'foo' in the current
 * (native) directory.
 */







|















|







6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
TestSimpleFilesystemObjCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int res, boolVal;
    const char *msg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "boolean");
	return TCL_ERROR;
    }
    if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
	return TCL_ERROR;
    }
    if (boolVal) {
	res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
	msg = (res == TCL_OK) ? "registered" : "failed";
    } else {
	res = Tcl_FSUnregister(&simpleFilesystem);
	msg = (res == TCL_OK) ? "unregistered" : "failed";
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
    return res;
}

/*
 * Treats a file name 'simplefs:/foo' by using the file 'foo' in the current
 * (native) directory.
 */
Changes to library/platform/pkgIndex.tcl.
1
2
3
package ifneeded platform        1.0.3 [list source [file join $dir platform.tcl]]
package ifneeded platform::shell 1.1.3 [list source [file join $dir shell.tcl]]


|

1
2
3
package ifneeded platform        1.0.3 [list source [file join $dir platform.tcl]]
package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]]

Changes to library/platform/shell.tcl.
100
101
102
103
104
105
106


107
108
109
110
111
112
113
114
115
    # Locate the platform package for injection into the specified
    # shell. We are using package management to find it, whereever it
    # is, instead of using hardwired relative paths. This allows us to
    # install the two packages as TMs without breaking the code
    # here. If the found package is wrapped we copy the code somewhere
    # where the spawned shell will be able to read it.



    set pl [package ifneeded platform [package require platform]]
    foreach {cmd base} $pl break

    set out 0
    if {[lindex [file system $base]] ne "native"} {
	set temp [TEMP]
	file copy -force $base $temp
	set base $temp
	set out 1







>
>

|







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
    # Locate the platform package for injection into the specified
    # shell. We are using package management to find it, whereever it
    # is, instead of using hardwired relative paths. This allows us to
    # install the two packages as TMs without breaking the code
    # here. If the found package is wrapped we copy the code somewhere
    # where the spawned shell will be able to read it.

    # Note: This code depends on the form of the 'provide' command
    # generated by tm.tcl. Keep them in sync. See Bug 2255235.
    set pl [package ifneeded platform [package require platform]]
    set base [lindex $pl end]

    set out 0
    if {[lindex [file system $base]] ne "native"} {
	set temp [TEMP]
	file copy -force $base $temp
	set base $temp
	set out 1
229
230
231
232
233
234
235
236
    # Fail if nothing worked.
    return -code error "Unable to determine a proper directory for temporary files"
}

# ### ### ### ######### ######### #########
## Ready

package provide platform::shell 1.1.3







|
231
232
233
234
235
236
237
238
    # Fail if nothing worked.
    return -code error "Unable to determine a proper directory for temporary files"
}

# ### ### ### ######### ######### #########
## Ready

package provide platform::shell 1.1.4
Changes to library/tm.tcl.
249
250
251
252
253
254
255










256
257
258
259
260
261
262
		    }

		    # We have found a candidate, generate a "provide
		    # script" for it, and remember it.  Note that we
		    # are using ::list to do this; locally [list]
		    # means something else without the namespace
		    # specifier.











		    package ifneeded $pkgname $pkgversion \
			"[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"

		    # We abort in this unknown handler only if we got
		    # a satisfying candidate for the requested
		    # package. Otherwise we still have to fallback to







>
>
>
>
>
>
>
>
>
>







249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
		    }

		    # We have found a candidate, generate a "provide
		    # script" for it, and remember it.  Note that we
		    # are using ::list to do this; locally [list]
		    # means something else without the namespace
		    # specifier.

		    # NOTE. When making changes to the format of the
		    # provide command generated below CHECK that the
		    # 'LOCATE' procedure in core file
		    # 'platform/shell.tcl' still understands it, or,
		    # if not, update its implementation appropriately.
		    #
		    # Right now LOCATE's implementation assumes that
		    # the path of the package file is the last element
		    # in the list.

		    package ifneeded $pkgname $pkgversion \
			"[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"

		    # We abort in this unknown handler only if we got
		    # a satisfying candidate for the requested
		    # package. Otherwise we still have to fallback to
Changes to macosx/Tcl-Common.xcconfig.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
//
// Tcl-Common.xcconfig --
//
//	This file contains the Xcode build settings comon to all
//	project configurations in Tcl.xcodeproj.
//
// Copyright (c) 2007-2008 Daniel A. Steffen <das@users.sourceforge.net>
//
// See the file "license.terms" for information on usage and redistribution
// of this file, and for a DISCLAIMER OF ALL WARRANTIES.
//
// RCS: @(#) $Id: Tcl-Common.xcconfig,v 1.2.2.9 2008/04/04 04:40:58 dgp Exp $
//

HEADER_SEARCH_PATHS = "$(DERIVED_FILE_DIR)/tcl" $(HEADER_SEARCH_PATHS)
OTHER_LDFLAGS = -headerpad_max_install_names -sectcreate __TEXT __info_plist "$(DERIVED_FILE_DIR)/tcl/Tclsh-Info.plist" $(OTHER_LDFLAGS)
INSTALL_PATH = $(BINDIR)
INSTALL_MODE_FLAG = go-w,a+rX
GCC_PREFIX_HEADER = $(DERIVED_FILE_DIR)/tcl/tclConfig.h
GCC_GENERATE_DEBUGGING_SYMBOLS = YES
GCC_NO_COMMON_BLOCKS = YES
GCC_DYNAMIC_NO_PIC = YES
GCC = $(DEVELOPER_DIR)/usr/bin/gcc
GCC_VERSION = 4.0
CC = $(GCC)-$(GCC_VERSION)
LD = $(CC)
WARNING_CFLAGS_GCC3 = -Wall -Wno-implicit-int -Wno-unused-parameter -Wno-deprecated-declarations
WARNING_CFLAGS = -Wextra -Wno-missing-field-initializers -Winit-self -Wpointer-arith -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS_GCC3) $(WARNING_CFLAGS)
BINDIR = $(PREFIX)/bin
CFLAGS = $(CFLAGS)
CPPFLAGS = -mmacosx-version-min=$(MACOSX_DEPLOYMENT_TARGET) $(CPPFLAGS)
FRAMEWORK_INSTALL_PATH = /Library/Frameworks
INCLUDEDIR = $(PREFIX)/include
LIBDIR = $(PREFIX)/lib











|














|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
//
// Tcl-Common.xcconfig --
//
//	This file contains the Xcode build settings comon to all
//	project configurations in Tcl.xcodeproj.
//
// Copyright (c) 2007-2008 Daniel A. Steffen <das@users.sourceforge.net>
//
// See the file "license.terms" for information on usage and redistribution
// of this file, and for a DISCLAIMER OF ALL WARRANTIES.
//
// RCS: @(#) $Id: Tcl-Common.xcconfig,v 1.2.2.10 2008/11/17 16:13:46 dgp Exp $
//

HEADER_SEARCH_PATHS = "$(DERIVED_FILE_DIR)/tcl" $(HEADER_SEARCH_PATHS)
OTHER_LDFLAGS = -headerpad_max_install_names -sectcreate __TEXT __info_plist "$(DERIVED_FILE_DIR)/tcl/Tclsh-Info.plist" $(OTHER_LDFLAGS)
INSTALL_PATH = $(BINDIR)
INSTALL_MODE_FLAG = go-w,a+rX
GCC_PREFIX_HEADER = $(DERIVED_FILE_DIR)/tcl/tclConfig.h
GCC_GENERATE_DEBUGGING_SYMBOLS = YES
GCC_NO_COMMON_BLOCKS = YES
GCC_DYNAMIC_NO_PIC = YES
GCC = $(DEVELOPER_DIR)/usr/bin/gcc
GCC_VERSION = 4.0
CC = $(GCC)-$(GCC_VERSION)
LD = $(CC)
WARNING_CFLAGS_GCC3 = -Wall -Wno-unused-parameter -Wno-deprecated-declarations
WARNING_CFLAGS = -Wextra -Wno-missing-field-initializers -Winit-self -Wpointer-arith -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS_GCC3) $(WARNING_CFLAGS)
BINDIR = $(PREFIX)/bin
CFLAGS = $(CFLAGS)
CPPFLAGS = -mmacosx-version-min=$(MACOSX_DEPLOYMENT_TARGET) $(CPPFLAGS)
FRAMEWORK_INSTALL_PATH = /Library/Frameworks
INCLUDEDIR = $(PREFIX)/include
LIBDIR = $(PREFIX)/lib
Changes to tests/for.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# Commands covered:  for, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.9.6.6 2006/10/23 21:01:51 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "for" operation.











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# Commands covered:  for, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.9.6.7 2008/11/17 16:13:46 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "for" operation.
195
196
197
198
199
200
201













202
203
204
205
206
207
208
	    catch {incr i 5} msg
	    catch {incr i -5} msg
	}
	set a [concat $a $i]
    }
    set a
} {1 3}














# Check "for" and "break".

test for-3.1 {TclCompileBreakCmd: arguments after "break"} {
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}







>
>
>
>
>
>
>
>
>
>
>
>
>







195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
	    catch {incr i 5} msg
	    catch {incr i -5} msg
	}
	set a [concat $a $i]
    }
    set a
} {1 3}
test for-2.7 {continue tests, uncompiled [for]} -body {
    set file [makeFile {
    	set guard 0
	for {set i 20} {$i > 0} {incr i -1} {
	    if {[incr guard]>30} {return BAD}
	    continue
	}
	return GOOD
    } source.file]
    source $file
} -cleanup {
    removeFile source.file
} -result GOOD

# Check "for" and "break".

test for-3.1 {TclCompileBreakCmd: arguments after "break"} {
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}
Changes to tests/registry.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.  All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: registry.test,v 1.14.2.8 2008/07/29 20:14:06 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint reg 0












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.  All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: registry.test,v 1.14.2.9 2008/11/17 16:13:46 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint reg 0
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
test registry-2.2 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.3 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.4 {DeleteKey: subkey at root level} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry keys HKEY_CLASSES_ROOT TclFoobar
} {}
test registry-2.5 {DeleteKey: subkey below root level} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar\\test]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-2.6 {DeleteKey: recursive delete} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-2.7 {DeleteKey: trailing backslashes} {win reg english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar\\} msg] $msg
} {1 {unable to delete key: The configuration registry key is invalid.}}
test registry-2.8 {DeleteKey: failure} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
} {}
test registry-2.9 {DeleteKey: unicode} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test\u00c7bar\\a
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test\u00c7bar\\b
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test\u00c7bar
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}

test registry-3.1 {DeleteValue} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 blort
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blat
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\baz test1
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\baz]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} test2
test registry-3.2 {DeleteValue: bad key} {win reg english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-3.3 {DeleteValue: bad value} {win reg english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blort
    set result [list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test1} msg] $msg]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {1 {unable to delete value "test1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}
test registry-3.4 {DeleteValue: Unicode} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\\u00c7baz \u00c7test1 blort
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\\u00c7baz test2 blat
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\\u00c7baz \u00c7test1
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\\u00c7baz]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} test2

test registry-4.1 {GetKeyNames: bad key} {win reg english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-4.2 {GetKeyNames} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz}
test registry-4.3 {GetKeyNames: remote key} {win reg nonPortable english} {
    set hostname [info hostname]
    registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar\\baz
    set result [registry keys \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz}
test registry-4.4 {GetKeyNames: empty key} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-4.5 {GetKeyNames: patterns} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-4.6 {GetKeyNames: names with spaces} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\ bar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}
test registry-4.7 {GetKeyNames: Unicode} {win reg english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\u00c7bar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} "baz\u00c7bar blat"
test registry-4.8 {GetKeyNames: Unicode} {win reg nt} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\u30b7bar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} "baz\u30b7bar blat"
test registry-4.9 {GetKeyNames: very long key [Bug 1682211]} {*}{
    -constraints {win reg}
    -setup {
	registry set HKEY_CLASSES_ROOT\\TclFoobar\\a
	registry set HKEY_CLASSES_ROOT\\TclFoobar\\b[string repeat x 254]
	registry set HKEY_CLASSES_ROOT\\TclFoobar\\c
    }
    -body {
	lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    }
    -cleanup {
	registry delete HKEY_CLASSES_ROOT\\TclFoobar
    }} \
    -result [list a b[string repeat x 254] c]

test registry-5.1 {GetType} {win reg english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-5.2 {GetType} {win reg english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to get type of value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}
test registry-5.3 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} none
test registry-5.4 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} sz
test registry-5.5 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} sz
test registry-5.6 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} expand_sz
test registry-5.7 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} binary
test registry-5.8 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} dword
test registry-5.9 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword_big_endian
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} dword_big_endian
test registry-5.10 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} link
test registry-5.11 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} multi_sz
test registry-5.12 {GetType} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} resource_list
test registry-5.13 {GetType: unknown types} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 24
test registry-5.14 {GetType: Unicode} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar va\u00c7l1 1 24
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar va\u00c7l1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 24

test registry-6.1 {GetValue} {win reg english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-6.2 {GetValue} {win reg english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to get value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}
test registry-6.3 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.4 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.5 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.6 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.7 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.8 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 32
test registry-6.9 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword_big_endian
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 32
test registry-6.10 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.11 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.12 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo\ bar baz} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{foo bar} baz}
test registry-6.13 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-6.14 {GetValue: truncation of multivalues with null elements} \
	{win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {a {} b} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} a
test registry-6.15 {GetValue} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.16 {GetValue: unknown types} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.17 {GetValue: Unicode value names} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val\u00c71 foobar multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val\u00c71]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} "foo ba\u30b7r baz"
test registry-6.19 {GetValue: values with Unicode strings} {win reg english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo ba\u00c7r baz} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} "foo ba r baz"

test registry-7.1 {GetValueNames: bad key} {win reg english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry values HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-7.2 {GetValueNames} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} baz
test registry-7.3 {GetValueNames} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar {} foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{} baz blat}
test registry-7.4 {GetValueNames: remote key} {win reg nonPortable english} {
    set hostname [info hostname]
    registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat
    set result [registry values \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar
    set result
} baz
test registry-7.5 {GetValueNames: empty key} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-7.6 {GetValueNames: patterns} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-7.7 {GetValueNames: names with spaces} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz\ bar foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-8.1 {OpenSubKey} {win reg nonPortable english} {
    # This test will only succeed if the current user does not have registry
    # access on the specified machine.
    list [catch {registry keys {\\mom\HKEY_LOCAL_MACHINE}} msg] $msg
} {1 {unable to open key: Access is denied.}}
test registry-8.2 {OpenSubKey} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} TclFoobar
test registry-8.3 {OpenSubKey} {win reg english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-9.1 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\} msg] $msg
} "1 {bad key \"\\\": must start with a valid root}"
test registry-9.2 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\foobar} msg] $msg







|
|
|


|
|
|
|



|
|
|
|



|
|


|
|


|
|
|
|
|
|




|
|
|
|
|
|



|
|


|
|
|
|

|

|
|
|
|
|
|




|
|


|
|
|
|




|
|
|



|
|
|
|



|
|
|
|
|
|



|
|
|
|
|
|



|
|
|
|
|
|



|
|
|
|
|
|





|
|
|


|


|




|
|


|
|
|

|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|




|
|


|
|
|

|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|




|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|



|
|
|




|
|


|
|
|
|



|
|
|
|
|
|




|
|
|



|
|
|
|



|
|
|
|
|
|



|
|
|
|
|
|









|
|
|
|



|
|







118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
test registry-2.2 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.3 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.4 {DeleteKey: subkey at root level} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry keys HKEY_CURRENT_USER TclFoobar
} {}
test registry-2.5 {DeleteKey: subkey below root level} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar\\test
    registry delete HKEY_CURRENT_USER\\TclFoobar\\test
    set result [registry keys HKEY_CURRENT_USER TclFoobar\\test]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {}
test registry-2.6 {DeleteKey: recursive delete} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar\\test1
    registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result [registry keys HKEY_CURRENT_USER TclFoobar]
    set result
} {}
test registry-2.7 {DeleteKey: trailing backslashes} {win reg english} {
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz
    list [catch {registry delete HKEY_CURRENT_USER\\TclFoobar\\} msg] $msg
} {1 {unable to delete key: The configuration registry key is invalid.}}
test registry-2.8 {DeleteKey: failure} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry delete HKEY_CURRENT_USER\\TclFoobar
} {}
test registry-2.9 {DeleteKey: unicode} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\test\u00c7bar\\a
    registry set HKEY_CURRENT_USER\\TclFoobar\\test\u00c7bar\\b
    registry delete HKEY_CURRENT_USER\\TclFoobar\\test\u00c7bar
    set result [registry keys HKEY_CURRENT_USER\\TclFoobar]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {}

test registry-3.1 {DeleteValue} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz test1 blort
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz test2 blat
    registry delete HKEY_CURRENT_USER\\TclFoobar\\baz test1
    set result [registry values HKEY_CURRENT_USER\\TclFoobar\\baz]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} test2
test registry-3.2 {DeleteValue: bad key} {win reg english} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    list [catch {registry delete HKEY_CURRENT_USER\\TclFoobar test} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-3.3 {DeleteValue: bad value} {win reg english} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz test2 blort
    set result [list [catch {registry delete HKEY_CURRENT_USER\\TclFoobar test1} msg] $msg]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {1 {unable to delete value "test1" from key "HKEY_CURRENT_USER\TclFoobar": The system cannot find the file specified.}}
test registry-3.4 {DeleteValue: Unicode} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\\u00c7baz \u00c7test1 blort
    registry set HKEY_CURRENT_USER\\TclFoobar\\\u00c7baz test2 blat
    registry delete HKEY_CURRENT_USER\\TclFoobar\\\u00c7baz \u00c7test1
    set result [registry values HKEY_CURRENT_USER\\TclFoobar\\\u00c7baz]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} test2

test registry-4.1 {GetKeyNames: bad key} {win reg english} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-4.2 {GetKeyNames} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz
    set result [registry keys HKEY_CURRENT_USER\\TclFoobar]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {baz}
test registry-4.3 {GetKeyNames: remote key} {win reg nonPortable english} {
    set hostname [info hostname]
    registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar\\baz
    set result [registry keys \\\\gaspode\\HKEY_CURRENT_USER\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar
    set result
} {baz}
test registry-4.4 {GetKeyNames: empty key} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar
    set result [registry keys HKEY_CURRENT_USER\\TclFoobar]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {}
test registry-4.5 {GetKeyNames: patterns} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz
    registry set HKEY_CURRENT_USER\\TclFoobar\\blat
    registry set HKEY_CURRENT_USER\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {baz blat}
test registry-4.6 {GetKeyNames: names with spaces} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz\ bar
    registry set HKEY_CURRENT_USER\\TclFoobar\\blat
    registry set HKEY_CURRENT_USER\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {{baz bar} blat}
test registry-4.7 {GetKeyNames: Unicode} {win reg english} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u00c7bar
    registry set HKEY_CURRENT_USER\\TclFoobar\\blat
    registry set HKEY_CURRENT_USER\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "baz\u00c7bar blat"
test registry-4.8 {GetKeyNames: Unicode} {win reg nt} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar
    registry set HKEY_CURRENT_USER\\TclFoobar\\blat
    registry set HKEY_CURRENT_USER\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "baz\u30b7bar blat"
test registry-4.9 {GetKeyNames: very long key [Bug 1682211]} {*}{
    -constraints {win reg}
    -setup {
	registry set HKEY_CURRENT_USER\\TclFoobar\\a
	registry set HKEY_CURRENT_USER\\TclFoobar\\b[string repeat x 254]
	registry set HKEY_CURRENT_USER\\TclFoobar\\c
    }
    -body {
	lsort [registry keys HKEY_CURRENT_USER\\TclFoobar]
    }
    -cleanup {
	registry delete HKEY_CURRENT_USER\\TclFoobar
    }} \
    -result [list a b[string repeat x 254] c]

test registry-5.1 {GetType} {win reg english} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    list [catch {registry type HKEY_CURRENT_USER\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-5.2 {GetType} {win reg english} {
    registry set HKEY_CURRENT_USER\\TclFoobar
    list [catch {registry type HKEY_CURRENT_USER\\TclFoobar val1} msg] $msg
} {1 {unable to get type of value "val1" from key "HKEY_CURRENT_USER\TclFoobar": The system cannot find the file specified.}}
test registry-5.3 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar none
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} none
test registry-5.4 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} sz
test registry-5.5 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar sz
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} sz
test registry-5.6 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar expand_sz
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} expand_sz
test registry-5.7 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 binary
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} binary
test registry-5.8 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 dword
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} dword
test registry-5.9 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 dword_big_endian
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} dword_big_endian
test registry-5.10 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 link
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} link
test registry-5.11 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar multi_sz
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} multi_sz
test registry-5.12 {GetType} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 resource_list
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} resource_list
test registry-5.13 {GetType: unknown types} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 24
    set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} 24
test registry-5.14 {GetType: Unicode} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar va\u00c7l1 1 24
    set result [registry type HKEY_CURRENT_USER\\TclFoobar va\u00c7l1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} 24

test registry-6.1 {GetValue} {win reg english} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    list [catch {registry get HKEY_CURRENT_USER\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-6.2 {GetValue} {win reg english} {
    registry set HKEY_CURRENT_USER\\TclFoobar
    list [catch {registry get HKEY_CURRENT_USER\\TclFoobar val1} msg] $msg
} {1 {unable to get value "val1" from key "HKEY_CURRENT_USER\TclFoobar": The system cannot find the file specified.}}
test registry-6.3 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar none
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} foobar
test registry-6.4 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} foobar
test registry-6.5 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} foobar
test registry-6.6 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar expand_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} foobar
test registry-6.7 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 binary
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} 1
test registry-6.8 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 0x20 dword
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} 32
test registry-6.9 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 0x20 dword_big_endian
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} 32
test registry-6.10 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 link
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} 1
test registry-6.11 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} foobar
test registry-6.12 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo\ bar baz} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {{foo bar} baz}
test registry-6.13 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {}
test registry-6.14 {GetValue: truncation of multivalues with null elements} \
	{win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {a {} b} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} a
test registry-6.15 {GetValue} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 resource_list
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} 1
test registry-6.16 {GetValue: unknown types} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 1 24
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} 1
test registry-6.17 {GetValue: Unicode value names} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val\u00c71 foobar multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val\u00c71]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} foobar
test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "foo ba\u30b7r baz"
test registry-6.19 {GetValue: values with Unicode strings} {win reg english} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u00c7r baz} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "foo ba r baz"

test registry-7.1 {GetValueNames: bad key} {win reg english} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    list [catch {registry values HKEY_CURRENT_USER\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-7.2 {GetValueNames} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar baz foobar
    set result [registry values HKEY_CURRENT_USER\\TclFoobar]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} baz
test registry-7.3 {GetValueNames} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1
    registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
    registry set HKEY_CURRENT_USER\\TclFoobar {} foobar3
    set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {{} baz blat}
test registry-7.4 {GetValueNames: remote key} {win reg nonPortable english} {
    set hostname [info hostname]
    registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar baz blat
    set result [registry values \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar
    set result
} baz
test registry-7.5 {GetValueNames: empty key} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar
    set result [registry values HKEY_CURRENT_USER\\TclFoobar]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {}
test registry-7.6 {GetValueNames: patterns} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1
    registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
    registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {baz blat}
test registry-7.7 {GetValueNames: names with spaces} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar baz\ bar foobar1
    registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
    registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {{baz bar} blat}

test registry-8.1 {OpenSubKey} {win reg nonPortable english} {
    # This test will only succeed if the current user does not have registry
    # access on the specified machine.
    list [catch {registry keys {\\mom\HKEY_LOCAL_MACHINE}} msg] $msg
} {1 {unable to open key: Access is denied.}}
test registry-8.2 {OpenSubKey} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar
    set result [registry keys HKEY_CURRENT_USER TclFoobar]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} TclFoobar
test registry-8.3 {OpenSubKey} {win reg english} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-9.1 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\} msg] $msg
} "1 {bad key \"\\\": must start with a valid root}"
test registry-9.2 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\foobar} msg] $msg
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-9.9 {ParseKeyName: null keys} {win reg english} {
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-10.1 {RecursiveDeleteKey} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-10.2 {RecursiveDeleteKey} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    set result [registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test4]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}

test registry-11.1 {SetValue: recursive creation} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat]
} foobar
test registry-11.2 {SetValue: modification} {win reg} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat frob
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat]
} frob
test registry-11.3 {SetValue: failure} {win reg nonPortable english} {
    # This test will only succeed if the current user does not have registry
    # access on the specified machine.
    list [catch {registry set {\\mom\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg
} {1 {unable to open key: Access is denied.}}

test registry-12.1 {BroadcastValue} {win reg} {
    list [catch {registry broadcast} msg] $msg
} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
test registry-12.2 {BroadcastValue} {win reg} {
    list [catch {registry broadcast "" -time} msg] $msg







|
|
|
|
|



|
|
|
|
|




|
|
|


|
|
|
|




|







558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-9.9 {ParseKeyName: null keys} {win reg english} {
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-10.1 {RecursiveDeleteKey} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\test1
    registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result [registry keys HKEY_CURRENT_USER TclFoobar]
    set result
} {}
test registry-10.2 {RecursiveDeleteKey} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\test1
    registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3
    set result [registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {}

test registry-11.1 {SetValue: recursive creation} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
    set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
} foobar
test registry-11.2 {SetValue: modification} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob
    set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
} frob
test registry-11.3 {SetValue: failure} {win reg nonPortable english} {
    # This test will only succeed if the current user does not have registry
    # access on the specified machine.
    list [catch {registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar} msg] $msg
} {1 {unable to open key: Access is denied.}}

test registry-12.1 {BroadcastValue} {win reg} {
    list [catch {registry broadcast} msg] $msg
} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
test registry-12.2 {BroadcastValue} {win reg} {
    list [catch {registry broadcast "" -time} msg] $msg
Changes to unix/Makefile.in.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is
# a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.127.2.54 2008/11/10 02:18:42 dgp Exp $

VERSION 		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#--------------------------------------------------------------------------






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is
# a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.127.2.55 2008/11/17 16:13:47 dgp Exp $

VERSION 		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#--------------------------------------------------------------------------
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
	@echo "Installing package msgcat 1.4.2 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.2.tm;
	@echo "Installing package tcltest 2.3.0 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.0.tm;

	@echo "Installing package platform 1.0.3 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.3.tm;
	@echo "Installing package platform::shell 1.1.3 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.3.tm;

	@echo "Installing library encoding directory";
	@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
		$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \
	done;
	@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \
	    echo "Customizing tcl module path"; \







|
|







810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
	@echo "Installing package msgcat 1.4.2 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.2.tm;
	@echo "Installing package tcltest 2.3.0 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.0.tm;

	@echo "Installing package platform 1.0.3 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.3.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;

	@echo "Installing library encoding directory";
	@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
		$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \
	done;
	@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \
	    echo "Customizing tcl module path"; \
Changes to unix/configure.
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260

6261
6262
6263


6264

6265
6266
6267
6268
6269
6270
6271
    LDFLAGS_ARCH=""
    TCL_EXPORT_FILE_SUFFIX=""
    UNSHARED_LIB_SUFFIX=""
    TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
    ECHO_VERSION='`echo ${VERSION}`'
    TCL_LIB_VERSIONS_OK=ok
    CFLAGS_DEBUG=-g
    CFLAGS_OPTIMIZE=-O
    if test "$GCC" = yes; then


	CFLAGS_WARNING="-Wall -Wno-implicit-int"

else


  CFLAGS_WARNING=""

fi

    TCL_NEEDS_EXP_FILE=0
    TCL_BUILD_EXP_FILE=""
    TCL_EXP_FILE=""
    # Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2







<


>
|


>
>
|
>







6251
6252
6253
6254
6255
6256
6257

6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
    LDFLAGS_ARCH=""
    TCL_EXPORT_FILE_SUFFIX=""
    UNSHARED_LIB_SUFFIX=""
    TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
    ECHO_VERSION='`echo ${VERSION}`'
    TCL_LIB_VERSIONS_OK=ok
    CFLAGS_DEBUG=-g

    if test "$GCC" = yes; then

	CFLAGS_OPTIMIZE="-O2"
	CFLAGS_WARNING="-Wall"

else

	CFLAGS_OPTIMIZE=-O
	CFLAGS_WARNING=""

fi

    TCL_NEEDS_EXP_FILE=0
    TCL_BUILD_EXP_FILE=""
    TCL_EXP_FILE=""
    # Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
6735
6736
6737
6738
6739
6740
6741

6742
6743
6744
6745
6746
6747
6748
	    if test "$GCC" = yes; then

		SHLIB_LD='${CC} -shared'

else

		CFLAGS="$CFLAGS -z"

		# Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
		#CFLAGS="$CFLAGS +DAportable"
		SHLIB_CFLAGS="+z"
		SHLIB_LD="${CC} -Wl,-b"

fi








>







6738
6739
6740
6741
6742
6743
6744
6745
6746
6747
6748
6749
6750
6751
6752
	    if test "$GCC" = yes; then

		SHLIB_LD='${CC} -shared'

else

		CFLAGS="$CFLAGS -z"
		CFLAGS_WARNING="$CFLAGS_WARNING +w1 +W392000"
		# Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
		#CFLAGS="$CFLAGS +DAportable"
		SHLIB_CFLAGS="+z"
		SHLIB_LD="${CC} -Wl,-b"

fi

Changes to unix/tcl.m4.
1097
1098
1099
1100
1101
1102
1103
1104
1105

1106


1107

1108
1109
1110
1111
1112
1113
1114
    LDFLAGS_ARCH=""
    TCL_EXPORT_FILE_SUFFIX=""
    UNSHARED_LIB_SUFFIX=""
    TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
    ECHO_VERSION='`echo ${VERSION}`'
    TCL_LIB_VERSIONS_OK=ok
    CFLAGS_DEBUG=-g
    CFLAGS_OPTIMIZE=-O
    AS_IF([test "$GCC" = yes], [

	CFLAGS_WARNING="-Wall -Wno-implicit-int"


    ], [CFLAGS_WARNING=""])

    TCL_NEEDS_EXP_FILE=0
    TCL_BUILD_EXP_FILE=""
    TCL_EXP_FILE=""
dnl FIXME: Replace AC_CHECK_PROG with AC_CHECK_TOOL once cross compiling is fixed.
dnl AC_CHECK_TOOL(AR, ar)
    AC_CHECK_PROG(AR, ar, ar)
    AS_IF([test "${AR}" = ""], [







<

>
|
>
>
|
>







1097
1098
1099
1100
1101
1102
1103

1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
    LDFLAGS_ARCH=""
    TCL_EXPORT_FILE_SUFFIX=""
    UNSHARED_LIB_SUFFIX=""
    TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
    ECHO_VERSION='`echo ${VERSION}`'
    TCL_LIB_VERSIONS_OK=ok
    CFLAGS_DEBUG=-g

    AS_IF([test "$GCC" = yes], [
	CFLAGS_OPTIMIZE="-O2"
	CFLAGS_WARNING="-Wall"
    ], [
	CFLAGS_OPTIMIZE=-O
	CFLAGS_WARNING=""
    ])
    TCL_NEEDS_EXP_FILE=0
    TCL_BUILD_EXP_FILE=""
    TCL_EXP_FILE=""
dnl FIXME: Replace AC_CHECK_PROG with AC_CHECK_TOOL once cross compiling is fixed.
dnl AC_CHECK_TOOL(AR, ar)
    AC_CHECK_PROG(AR, ar, ar)
    AS_IF([test "${AR}" = ""], [
Changes to win/Makefile.in.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in" then it
# is a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.71.2.35 2008/11/10 02:18:42 dgp Exp $

VERSION = @TCL_VERSION@

#--------------------------------------------------------------------------
# Things you can change to personalize the Makefile for your own site (you can
# make these changes in either Makefile.in or Makefile, but changes to
# Makefile will get lost if you re-run the configuration script).






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in" then it
# is a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.71.2.36 2008/11/17 16:13:48 dgp Exp $

VERSION = @TCL_VERSION@

#--------------------------------------------------------------------------
# Things you can change to personalize the Makefile for your own site (you can
# make these changes in either Makefile.in or Makefile, but changes to
# Makefile will get lost if you re-run the configuration script).
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
	    done;
	@echo "Installing package msgcat 1.4.2 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.2.tm;
	@echo "Installing package tcltest 2.3.0 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.0.tm;
	@echo "Installing package platform 1.0.3 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.3.tm;
	@echo "Installing package platform::shell 1.1.3 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.3.tm;
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done;

install-tzdata:
	@echo "Installing time zone data"







|
|







646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
	    done;
	@echo "Installing package msgcat 1.4.2 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.2.tm;
	@echo "Installing package tcltest 2.3.0 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.0.tm;
	@echo "Installing package platform 1.0.3 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.3.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done;

install-tzdata:
	@echo "Installing time zone data"
Changes to win/configure.
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
	DLLSUFFIX="\${DBGX}.dll"
	SHLIB_SUFFIX=.dll

	EXTRA_CFLAGS="${extra_cflags}"

	CFLAGS_DEBUG=-g
	CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
	CFLAGS_WARNING="-Wall -Wno-implicit-int"
	LDFLAGS_DEBUG=
	LDFLAGS_OPTIMIZE=

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-o \$@"
	CC_EXENAME="-o \$@"








|







3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
	DLLSUFFIX="\${DBGX}.dll"
	SHLIB_SUFFIX=.dll

	EXTRA_CFLAGS="${extra_cflags}"

	CFLAGS_DEBUG=-g
	CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
	CFLAGS_WARNING="-Wall"
	LDFLAGS_DEBUG=
	LDFLAGS_OPTIMIZE=

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-o \$@"
	CC_EXENAME="-o \$@"

Changes to win/tcl.m4.
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
	DLLSUFFIX="\${DBGX}.dll"
	SHLIB_SUFFIX=.dll

	EXTRA_CFLAGS="${extra_cflags}"

	CFLAGS_DEBUG=-g
	CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
	CFLAGS_WARNING="-Wall -Wno-implicit-int"
	LDFLAGS_DEBUG=
	LDFLAGS_OPTIMIZE=

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-o \[$]@"
	CC_EXENAME="-o \[$]@"








|







525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
	DLLSUFFIX="\${DBGX}.dll"
	SHLIB_SUFFIX=.dll

	EXTRA_CFLAGS="${extra_cflags}"

	CFLAGS_DEBUG=-g
	CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
	CFLAGS_WARNING="-Wall"
	LDFLAGS_DEBUG=
	LDFLAGS_OPTIMIZE=

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-o \[$]@"
	CC_EXENAME="-o \[$]@"