Tcl Source Code

Check-in [579ee14b07]
Login

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

Overview
Comment:merge to rc
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-6-b2-rc
Files: files | file ages | folders
SHA1: 579ee14b07fbf7f7d0babbff6daa0ce2a3a934b3
User & Date: dgp 2011-08-02 14:06:01
Context
2011-08-02
14:46
merge to rc check-in: eba2e95ed3 user: dgp tags: core-8-6-b2-rc
14:06
merge to rc check-in: 579ee14b07 user: dgp tags: core-8-6-b2-rc
14:04
Updates for 8.6b2 release. check-in: 00319e0051 user: dgp tags: trunk
2011-07-28
15:56
merge to rc check-in: b77ad4ed48 user: dgp tags: core-8-6-b2-rc
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.


































1
2
3
4
5
6
7

































2011-07-28  Reinhard Max  <[email protected]>

	* unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for
	NEED_FAKE_RFC2553.
	* unix/configure:	autoconf-2.59

2011-07-28  Don Porter  <[email protected]>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
2011-08-02  Don Porter  <[email protected]>

	* changes:	Updates for 8.6b2 release.

2011-08-02  Donal K. Fellows  <[email protected]>

	* generic/tclObj.c (Tcl_DbIncrRefCount, Tcl_DbDecrRefCount)
	(Tcl_DbIsShared): [Bug 3384007]: Fix the panic messages so they share
	what should be shared and have the right number of spaces.

2011-08-01  Miguel Sofer  <[email protected]>

	* generic/tclProc.c (TclProcCompileProc): [Bug 3383616]: Fix for leak
	of resolveInfo when recompiling procs. Thanks go to Gustaf Neumann for
	detecting the bug and providing the fix.

2011-08-01  Donal K. Fellows  <[email protected]>

	* doc/tclvars.n (EXAMPLES): Added some examples of how some of the
	standard global variables can be used, following prompting by a
	request by Robert Hicks.

	* tools/tcltk-man2html.tcl (plus-pkgs): [Bug 3382474]: Added code to
	determine the version number of contributed packages from their
	directory names so that HTML documentation builds are less confusing.

2011-07-29  Donal K. Fellows  <[email protected]>

	* tools/tcltk-man2html.tcl (ensemble_commands, remap_link_target):
	Small enhancements to improve cross-linking with contributed packages.
	* tools/tcltk-man2html-utils.tcl (insert-cross-references): Enhance to
	cope with contributed packages' C API.

2011-07-28  Reinhard Max  <[email protected]>

	* unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for
	NEED_FAKE_RFC2553.
	* unix/configure:	autoconf-2.59

2011-07-28  Don Porter  <[email protected]>

Changes to changes.

7945
7946
7947
7948
7949
7950
7951


7952
7953
7954
2011-06-22 (new feature) DEB_HOST_MULTIARCH support (kupries)
=> platform 1.0.10

2011-07-15 (bug fix)[3357771] Prevent circular refs in bytecode (porter)

2011-07-28 tzdata updated to Olson's tzdata2011h (porter)



Many more Tcl built-in command errors now set an -errorcode.

--- Released 8.6b2, August 3, 2011 --- See ChangeLog for details ---







>
>


|
7945
7946
7947
7948
7949
7950
7951
7952
7953
7954
7955
7956
2011-06-22 (new feature) DEB_HOST_MULTIARCH support (kupries)
=> platform 1.0.10

2011-07-15 (bug fix)[3357771] Prevent circular refs in bytecode (porter)

2011-07-28 tzdata updated to Olson's tzdata2011h (porter)

2011-08-01 (bug fix)[3383616] memleak exposed by XOTcl (neumann,sofer)

Many more Tcl built-in command errors now set an -errorcode.

--- Released 8.6b2, August 5, 2011 --- See ChangeLog for details ---

Changes to doc/tclvars.n.

481
482
483
484
485
486
487

488
489
490
491
492
493
494
hold the version number for this version of Tcl in the form \fIx.y\fR.
Changes to \fIx\fR represent major changes with probable
incompatibilities and changes to \fIy\fR represent small enhancements and
bug fixes that retain backward compatibility.
The value of this variable is returned by the \fBinfo tclversion\fR
command.
.SH "OTHER GLOBAL VARIABLES"

The following variables are only guaranteed to exist in \fBtclsh\fR
and \fBwish\fR executables; the Tcl library does not define them
itself but many Tcl environments do.
.TP 6
\fBargc\fR
.
The number of arguments to \fBtclsh\fR or \fBwish\fR.







>







481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
hold the version number for this version of Tcl in the form \fIx.y\fR.
Changes to \fIx\fR represent major changes with probable
incompatibilities and changes to \fIy\fR represent small enhancements and
bug fixes that retain backward compatibility.
The value of this variable is returned by the \fBinfo tclversion\fR
command.
.SH "OTHER GLOBAL VARIABLES"
.PP
The following variables are only guaranteed to exist in \fBtclsh\fR
and \fBwish\fR executables; the Tcl library does not define them
itself but many Tcl environments do.
.TP 6
\fBargc\fR
.
The number of arguments to \fBtclsh\fR or \fBwish\fR.
504
505
506
507
508
509
510




































511
512
513
514
515
516
517
518
was invoked.
.TP 6
\fBtcl_interactive\fR
.
Contains 1 if \fBtclsh\fR or \fBwish\fR is running interactively (no
script was specified and standard input is a terminal-like device), 0
otherwise.




































.SH "SEE ALSO"
eval(n), library(n), tclsh(1), tkvars(n), wish(1)
.SH KEYWORDS
arithmetic, bytecode, compiler, error, environment, POSIX, precision,
subprocess, user, variables
'\" Local Variables:
'\" mode: nroff
'\" End:







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








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
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
was invoked.
.TP 6
\fBtcl_interactive\fR
.
Contains 1 if \fBtclsh\fR or \fBwish\fR is running interactively (no
script was specified and standard input is a terminal-like device), 0
otherwise.
.SH EXAMPLES
.PP
To add a directory to the collection of locations searched by
\fBpackage require\fR, e.g., because of some application-specific
packages that are used, the \fBauto_path\fR variable needs to be
updated:
.PP
.CS
lappend ::\fBauto_path\fR [file join [pwd] "theLibDir"]
.CE
.PP
A simple though not very robust way to handle command line arguments
of the form
.QW "\-foo 1 \-bar 2"
is to load them into an array having first loaded in the default settings:
.CS
array set arguments {-foo 0 -bar 0 -grill 0}
array set arguments $::\fBargv\fR
puts "foo is $arguments(-foo)"
puts "bar is $arguments(-bar)"
puts "grill is $arguments(-grill)"
.CE
.PP
The \fBargv0\fR global variable can be used (in conjunction with the
\fBinfo script\fR command) to determine whether the current script is
being executed as the main script or loaded as a library.  This is
useful because it allows a single script to be used as both a library
and a demonstration of that library:
.PP
.CS
if {$::\fBargv0\fR eq [info script]} {
    # running as: tclsh example.tcl
} else {
    package provide Example 1.0
}
.CE
.SH "SEE ALSO"
eval(n), library(n), tclsh(1), tkvars(n), wish(1)
.SH KEYWORDS
arithmetic, bytecode, compiler, error, environment, POSIX, precision,
subprocess, user, variables
'\" Local Variables:
'\" mode: nroff
'\" End:

Changes to generic/tclObj.c.

3709
3710
3711
3712
3713
3714
3715

3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {

	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",
		    "Trying to incr ref count of ",
		    "Tcl_Obj allocated in another thread");
	}
    }
# endif
#endif
    ++(objPtr)->refCount;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbDecrRefCount --







>
|

<

<





|
|
<


|
|







3709
3710
3711
3712
3713
3714
3715
3716
3717
3718

3719

3720
3721
3722
3723
3724
3725
3726

3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
	Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
	Tcl_HashEntry *hPtr;



	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
                    "incr ref count");

	}
    }
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */
    ++(objPtr)->refCount;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbDecrRefCount --
3774
3775
3776
3777
3778
3779
3780

3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811

3812
3813
3814
3815
3816
3817
3818
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {

	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",
		    "Trying to decr ref count of ",
		    "Tcl_Obj allocated in another thread");
	}

	/*
	 * If the Tcl_Obj is going to be deleted, remove the entry.
	 */

	if ((objPtr->refCount - 1) <= 0) {
	    ObjData *objData = Tcl_GetHashValue(hPtr);

	    if (objData != NULL) {
		ckfree(objData);
	    }

	    Tcl_DeleteHashEntry(hPtr);
	}
    }
# endif
#endif

    if (--(objPtr)->refCount <= 0) {
	TclFreeObj(objPtr);
    }
}

/*
 *----------------------------------------------------------------------







>
|

<

<





|
|
<
















|
|
>







3772
3773
3774
3775
3776
3777
3778
3779
3780
3781

3782

3783
3784
3785
3786
3787
3788
3789

3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
	Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
	Tcl_HashEntry *hPtr;



	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
                    "decr ref count");

	}

	/*
	 * If the Tcl_Obj is going to be deleted, remove the entry.
	 */

	if ((objPtr->refCount - 1) <= 0) {
	    ObjData *objData = Tcl_GetHashValue(hPtr);

	    if (objData != NULL) {
		ckfree(objData);
	    }

	    Tcl_DeleteHashEntry(hPtr);
	}
    }
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */

    if (--(objPtr)->refCount <= 0) {
	TclFreeObj(objPtr);
    }
}

/*
 *----------------------------------------------------------------------
3854
3855
3856
3857
3858
3859
3860

3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {

	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",
		    "Trying to check shared status of",
		    "Tcl_Obj allocated in another thread");
	}
    }
# endif
#endif

#ifdef TCL_COMPILE_STATS
    Tcl_MutexLock(&tclObjMutex);
    if ((objPtr)->refCount <= 1) {
	tclObjsShared[1]++;
    } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
	tclObjsShared[(objPtr)->refCount]++;
    } else {
	tclObjsShared[0]++;
    }
    Tcl_MutexUnlock(&tclObjMutex);
#endif

    return ((objPtr)->refCount > 1);
}

/*
 *----------------------------------------------------------------------
 *







>
|

|
<





|
|
<


|
|











|







3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861

3862
3863
3864
3865
3866
3867
3868

3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
	Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
	Tcl_HashEntry *hPtr;


	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
                    "check shared status");

	}
    }
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */

#ifdef TCL_COMPILE_STATS
    Tcl_MutexLock(&tclObjMutex);
    if ((objPtr)->refCount <= 1) {
	tclObjsShared[1]++;
    } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
	tclObjsShared[(objPtr)->refCount]++;
    } else {
	tclObjsShared[0]++;
    }
    Tcl_MutexUnlock(&tclObjMutex);
#endif /* TCL_COMPILE_STATS */

    return ((objPtr)->refCount > 1);
}

/*
 *----------------------------------------------------------------------
 *

Changes to generic/tclProc.c.

2059
2060
2061
2062
2063
2064
2065







2066
2067
2068
2069
2070
2071
2072
		procPtr->firstLocalPtr = NULL;
	    }
	    procPtr->lastLocalPtr = lastPtr;
	    while (clPtr) {
		CompiledLocal *toFree = clPtr;

		clPtr = clPtr->nextPtr;







		ckfree(toFree);
	    }
	    procPtr->numCompiledLocals = procPtr->numArgs;
	}

	TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr,
		/* isProcCallFrame */ 0);







>
>
>
>
>
>
>







2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
		procPtr->firstLocalPtr = NULL;
	    }
	    procPtr->lastLocalPtr = lastPtr;
	    while (clPtr) {
		CompiledLocal *toFree = clPtr;

		clPtr = clPtr->nextPtr;
		if (toFree->resolveInfo) {
		    if (toFree->resolveInfo->deleteProc) {
			toFree->resolveInfo->deleteProc(toFree->resolveInfo);
		    } else {
			ckfree(toFree->resolveInfo);
		    }
		}
		ckfree(toFree);
	    }
	    procPtr->numCompiledLocals = procPtr->numArgs;
	}

	TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr,
		/* isProcCallFrame */ 0);

Changes to tests/encoding.test.

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
54
55
56
57
58
59
60
61
62
63
64
65

66
67
68
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
104


105
106
107
108
109
110


111
112
113
114
115
116
117
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
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 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.

package require tcltest 2

namespace eval ::tcl::test::encoding {
    variable x

namespace import -force ::tcltest::*

proc toutf {args} {
    variable x
    lappend x "toutf $args"
}
proc fromutf {args} {
    variable x
    lappend x "fromutf $args"
}

proc runtests {} {

    variable x

# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]


# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested

test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {
    testencoding create foo [namespace origin toutf] [namespace origin fromutf]
    set old [encoding system]


    encoding system foo
    set x {}
    encoding convertto abcd


    encoding system $old
    testencoding delete foo
    set x
} {{fromutf }}
test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {
    testencoding create foo [namespace origin toutf] [namespace origin fromutf]
    set x {}
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{fromutf }}
test encoding-1.3 {Tcl_GetEncoding: load encoding} {
    list [encoding convertto jis0208 \u4e4e] \
	[encoding convertfrom jis0208 8C]
} "8C \u4e4e"

test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
    encoding convertto jis0208 \u4e4e
} {8C}
test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} {
    set system [encoding system]
    set path [encoding dirs]

    encoding system shiftjis		;# incr ref count
    encoding dirs [list [pwd]]
    set x [encoding convertto shiftjis \u4e4e]	;# old one found   
    encoding system identity
    llength shiftjis		;# Shimmer away any cache of Tcl_Encoding
    lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg

    encoding system identity
    encoding dirs $path
    encoding system $system
    set x
} "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"

test encoding-3.1 {Tcl_GetEncodingName, NULL} {
    set old [encoding system]

    encoding system shiftjis
    set x [encoding system]

    encoding system $old
    set x
} {shiftjis}
test encoding-3.2 {Tcl_GetEncodingName, non-null} {
    set old [fconfigure stdout -encoding]

    fconfigure stdout -encoding jis0208
    set x [fconfigure stdout -encoding]

    fconfigure stdout -encoding $old
    set x
} {jis0208}

test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
    cd [makeDirectory tmp]
    makeDirectory [file join tmp encoding]
    makeFile {} [file join tmp encoding junk.enc]
    makeFile {} [file join tmp encoding junk2.enc]
    set path [encoding dirs]
    encoding dirs {}
    catch {unset encodings}
    catch {unset x}

    foreach encoding [encoding names] {
	set encodings($encoding) 1
    }


    encoding dirs [list [file join [pwd] encoding]]
    foreach encoding [encoding names] {
	if {![info exists encodings($encoding)]} {
	    lappend x $encoding
	}
    }


    encoding dirs $path
    cd [workingDirectory]
    removeFile [file join tmp encoding junk2.enc]
    removeFile [file join tmp encoding junk.enc]
    removeDirectory [file join tmp encoding]
    removeDirectory tmp
    lsort $x
} {junk junk2}

test encoding-5.1 {Tcl_SetSystemEncoding} {
    set old [encoding system]

    encoding system jis0208
    set x [encoding convertto \u4e4e]

    encoding system identity
    encoding system $old
    set x
} {8C}
test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
    set old [encoding system]
    encoding system $old
    string compare $old [encoding system]
} {0}

test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} {
    testencoding create foo [namespace code {toutf 1}] \
	[namespace code {fromutf 2}]
    set x {}
    encoding convertfrom foo abcd
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{toutf 1} {fromutf 2}}
test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
    testencoding create foo [namespace code {toutf a}] \
	[namespace code {fromutf b}]
    set x {}
    encoding convertfrom foo abcd
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{toutf a} {fromutf b}}

test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
    encoding convertfrom jis0208 8c8c8c8c
} "\u543e\u543e\u543e\u543e"
test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
    set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C

|
|




|
|


















<





>
|



|
<

>
>



>
>


<
|





|









|


>






>



<
|

|

>

|
>

<
|
|

>

|
>

<
|

|


<
<




>



>
>






>
>






<
|

|

>

|
>


<
|













|








|







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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
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
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1997 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.

package require tcltest 2

namespace eval ::tcl::test::encoding {
    variable x

namespace import -force ::tcltest::*

proc toutf {args} {
    variable x
    lappend x "toutf $args"
}
proc fromutf {args} {
    variable x
    lappend x "fromutf $args"
}

proc runtests {} {

    variable x

# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]

# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested

test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup {

    set old [encoding system]
} -constraints {testencoding} -body {
    testencoding create foo [namespace origin toutf] [namespace origin fromutf]
    encoding system foo
    set x {}
    encoding convertto abcd
    return $x
} -cleanup {
    encoding system $old
    testencoding delete foo

} -result {{fromutf }}
test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {
    testencoding create foo [namespace origin toutf] [namespace origin fromutf]
    set x {}
    encoding convertto foo abcd
    testencoding delete foo
    return $x
} {{fromutf }}
test encoding-1.3 {Tcl_GetEncoding: load encoding} {
    list [encoding convertto jis0208 \u4e4e] \
	[encoding convertfrom jis0208 8C]
} "8C \u4e4e"

test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
    encoding convertto jis0208 \u4e4e
} {8C}
test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
    set system [encoding system]
    set path [encoding dirs]
} -constraints {testencoding} -body {
    encoding system shiftjis		;# incr ref count
    encoding dirs [list [pwd]]
    set x [encoding convertto shiftjis \u4e4e]	;# old one found   
    encoding system identity
    llength shiftjis		;# Shimmer away any cache of Tcl_Encoding
    lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
} -cleanup {
    encoding system identity
    encoding dirs $path
    encoding system $system

} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"

test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup {
    set old [encoding system]
} -body {
    encoding system shiftjis
    encoding system
} -cleanup {
    encoding system $old

} -result {shiftjis}
test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup {
    set old [fconfigure stdout -encoding]
} -body {
    fconfigure stdout -encoding jis0208
    fconfigure stdout -encoding
} -cleanup {
    fconfigure stdout -encoding $old

} -result {jis0208}

test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup {
    cd [makeDirectory tmp]
    makeDirectory [file join tmp encoding]


    set path [encoding dirs]
    encoding dirs {}
    catch {unset encodings}
    catch {unset x}
} -body {
    foreach encoding [encoding names] {
	set encodings($encoding) 1
    }
    makeFile {} [file join tmp encoding junk.enc]
    makeFile {} [file join tmp encoding junk2.enc]
    encoding dirs [list [file join [pwd] encoding]]
    foreach encoding [encoding names] {
	if {![info exists encodings($encoding)]} {
	    lappend x $encoding
	}
    }
    lsort $x
} -cleanup {
    encoding dirs $path
    cd [workingDirectory]
    removeFile [file join tmp encoding junk2.enc]
    removeFile [file join tmp encoding junk.enc]
    removeDirectory [file join tmp encoding]
    removeDirectory tmp

} -result {junk junk2}

test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
    set old [encoding system]
} -body {
    encoding system jis0208
    encoding convertto \u4e4e
} -cleanup {
    encoding system identity
    encoding system $old

} -result {8C}
test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
    set old [encoding system]
    encoding system $old
    string compare $old [encoding system]
} {0}

test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} {
    testencoding create foo [namespace code {toutf 1}] \
	[namespace code {fromutf 2}]
    set x {}
    encoding convertfrom foo abcd
    encoding convertto foo abcd
    testencoding delete foo
    return $x
} {{toutf 1} {fromutf 2}}
test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
    testencoding create foo [namespace code {toutf a}] \
	[namespace code {fromutf b}]
    set x {}
    encoding convertfrom foo abcd
    encoding convertto foo abcd
    testencoding delete foo
    return $x
} {{toutf a} {fromutf b}}

test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
    encoding convertfrom jis0208 8c8c8c8c
} "\u543e\u543e\u543e\u543e"
test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
    set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
    puts -nonewline $f "ab\x8c\xc1g"
    close $f
    set f [open [file join [temporaryDirectory] dummy] r]
    fconfigure $f -translation binary -encoding shiftjis    
    set x [read $f]
    close $f
    file delete [file join [temporaryDirectory] dummy]
    set x
} "ab\u4e4eg"

test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
    encoding convertto jis0208 "\u543e\u543e\u543e\u543e"
} {8c8c8c8c}
test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
    set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e







|







177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
    puts -nonewline $f "ab\x8c\xc1g"
    close $f
    set f [open [file join [temporaryDirectory] dummy] r]
    fconfigure $f -translation binary -encoding shiftjis    
    set x [read $f]
    close $f
    file delete [file join [temporaryDirectory] dummy]
    return $x
} "ab\u4e4eg"

test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
    encoding convertto jis0208 "\u543e\u543e\u543e\u543e"
} {8c8c8c8c}
test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
    set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
    puts -nonewline $f "ab\u4e4eg"
    close $f
    set f [open [file join [temporaryDirectory] dummy] r]
    fconfigure $f -translation binary -encoding iso8859-1
    set x [read $f]
    close $f
    file delete [file join [temporaryDirectory] dummy]
    set x
} "ab\x8c\xc1g"

proc viewable {str} {
    set res ""
    foreach c [split $str {}] {
	if {[string is print $c] && [string is ascii $c]} {
	    append res $c







|







205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
    puts -nonewline $f "ab\u4e4eg"
    close $f
    set f [open [file join [temporaryDirectory] dummy] r]
    fconfigure $f -translation binary -encoding iso8859-1
    set x [read $f]
    close $f
    file delete [file join [temporaryDirectory] dummy]
    return $x
} "ab\x8c\xc1g"

proc viewable {str} {
    set res ""
    foreach c [split $str {}] {
	if {[string is print $c] && [string is ascii $c]} {
	    append res $c
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
} "\u4e4e"
test encoding-11.5 {LoadEncodingFile: escape file} {
    viewable [encoding convertto iso2022 \u4e4e]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.5.1 {LoadEncodingFile: escape file} {
    viewable [encoding convertto iso2022-jp \u4e4e]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
    set system [encoding system]
    set path [encoding dirs]
    encoding system identity

    cd [temporaryDirectory]
    encoding dirs [file join tmp encoding]
    makeDirectory tmp
    makeDirectory [file join tmp encoding]
    set f [open [file join tmp encoding splat.enc] w]
    fconfigure $f -translation binary 
    puts $f "abcdefghijklmnop"
    close $f
    set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]

    file delete [file join [temporaryDirectory] tmp encoding splat.enc]
    removeDirectory [file join tmp encoding]
    removeDirectory tmp
    cd [workingDirectory]
    encoding dirs $path
    encoding system $system
    set x
} {1 {invalid encoding file "splat"}}

# OpenEncodingFile is fully tested by the rest of the tests in this file.

test encoding-12.1 {LoadTableEncoding: normal encoding} {
    set x [encoding convertto iso8859-3 \u120]
    append x [encoding convertto iso8859-3 \ud5]
    append x [encoding convertfrom iso8859-3 \xd5]







|



>








|
>






<
|







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
} "\u4e4e"
test encoding-11.5 {LoadEncodingFile: escape file} {
    viewable [encoding convertto iso2022 \u4e4e]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.5.1 {LoadEncodingFile: escape file} {
    viewable [encoding convertto iso2022-jp \u4e4e]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
    set system [encoding system]
    set path [encoding dirs]
    encoding system identity
} -body {
    cd [temporaryDirectory]
    encoding dirs [file join tmp encoding]
    makeDirectory tmp
    makeDirectory [file join tmp encoding]
    set f [open [file join tmp encoding splat.enc] w]
    fconfigure $f -translation binary 
    puts $f "abcdefghijklmnop"
    close $f
    encoding convertto splat \u4e4e
} -returnCodes error -cleanup {
    file delete [file join [temporaryDirectory] tmp encoding splat.enc]
    removeDirectory [file join tmp encoding]
    removeDirectory tmp
    cd [workingDirectory]
    encoding dirs $path
    encoding system $system

} -result {invalid encoding file "splat"}

# OpenEncodingFile is fully tested by the rest of the tests in this file.

test encoding-12.1 {LoadTableEncoding: normal encoding} {
    set x [encoding convertto iso8859-3 \u120]
    append x [encoding convertto iso8859-3 \ud5]
    append x [encoding convertfrom iso8859-3 \xd5]
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
test encoding-14.1 {BinaryProc} {
    encoding convertto identity \x12\x34\x56\xff\x69
} "\x12\x34\x56\xc3\xbf\x69"

test encoding-15.1 {UtfToUtfProc} {
    encoding convertto utf-8 \xa3
} "\xc2\xa3"

test encoding-15.2 {UtfToUtfProc null character output} {
    set x \u0000
    set y [encoding convertto utf-8 \u0000]
    set y [encoding convertfrom identity $y]
    binary scan $y H* z
    list [string bytelength $x] [string bytelength $y] $z
} {2 1 00}

test encoding-15.3 {UtfToUtfProc null character input} {
    set x [encoding convertfrom identity \x00]
    set y [encoding convertfrom utf-8 $x]
    binary scan [encoding convertto identity $y] H* z
    list [string bytelength $x] [string bytelength $y] $z
} {1 2 c080}








<







<







305
306
307
308
309
310
311

312
313
314
315
316
317
318

319
320
321
322
323
324
325
test encoding-14.1 {BinaryProc} {
    encoding convertto identity \x12\x34\x56\xff\x69
} "\x12\x34\x56\xc3\xbf\x69"

test encoding-15.1 {UtfToUtfProc} {
    encoding convertto utf-8 \xa3
} "\xc2\xa3"

test encoding-15.2 {UtfToUtfProc null character output} {
    set x \u0000
    set y [encoding convertto utf-8 \u0000]
    set y [encoding convertfrom identity $y]
    binary scan $y H* z
    list [string bytelength $x] [string bytelength $y] $z
} {2 1 00}

test encoding-15.3 {UtfToUtfProc null character input} {
    set x [encoding convertfrom identity \x00]
    set y [encoding convertfrom utf-8 $x]
    binary scan [encoding convertto identity $y] H* z
    list [string bytelength $x] [string bytelength $y] $z
} {1 2 c080}

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
} [list [string length $iso2022uniData] $iso2022uniData]
test encoding-23.3 {iso2022-jp escape encoding test} {
    # read $fis <size> reads size in chars, not raw bytes.
    set fid [open iso2022.txt r]
    fconfigure $fid -encoding iso2022-jp
    set data [read $fid 50]
    close $fid
    set data
} [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
cd [workingDirectory]












test encoding-24.1 {EscapeFreeProc on open channels} -constraints {
	exec
} -setup {
    # Bug #524674 input
    set file [makeFile {
	set f [open [file join [file dirname [info script]] iso2022.txt]]
	fconfigure $f -encoding iso2022-jp
	gets $f
    } iso2022.tcl]
} -body {
    exec [interpreter] $file
} -cleanup {
    removeFile iso2022.tcl
} -result {}


test encoding-24.2 {EscapeFreeProc on open channels} -constraints {
	exec
} -setup {
    # Bug #524674 output
    set file [makeFile {
	encoding system cp1252;	# Bug #2891556 crash revelator
	fconfigure stdout -encoding iso2022-jp
	puts ab\u4e4e\u68d9g
	testfinexit
    } iso2022.tcl]
} -body {
    viewable [exec [interpreter] $file]
} -cleanup {
    removeFile iso2022.tcl
} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"

test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
    # Bug #219314 - if we don't free escape encodings correctly on
    # channel closure, we go boom
    set file [makeFile {
	encoding system iso2022-jp
	set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
	puts $a
    } iso2022.tcl]
    set f [open "|[list [interpreter] $file]"]
    fconfigure $f -encoding iso2022-jp







|



>
>
>
>
>
>
>
>
>
>
>
|
|
<
<
<



<
<
<
<
<
<
|
>
|
<
<

|




<
|
<
<
<
|
<

|
|







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
} [list [string length $iso2022uniData] $iso2022uniData]
test encoding-23.3 {iso2022-jp escape encoding test} {
    # read $fis <size> reads size in chars, not raw bytes.
    set fid [open iso2022.txt r]
    fconfigure $fid -encoding iso2022-jp
    set data [read $fid 50]
    close $fid
    return $data
} [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
cd [workingDirectory]

# Code to make the next few tests more intelligible; the code being tested
# should be in the body of the test!
proc runInSubprocess {contents {filename iso2022.tcl}} {
    set theFile [makeFile $contents $filename]
    try {
	exec [interpreter] $theFile
    } finally {
	removeFile $theFile
    }
}

test encoding-24.1 {EscapeFreeProc on open channels} exec {
    runInSubprocess {



	set f [open [file join [file dirname [info script]] iso2022.txt]]
	fconfigure $f -encoding iso2022-jp
	gets $f






    }
} {}
test encoding-24.2 {EscapeFreeProc on open channels} exec {


    # Bug #524674 output
    viewable [runInSubprocess {
	encoding system cp1252;	# Bug #2891556 crash revelator
	fconfigure stdout -encoding iso2022-jp
	puts ab\u4e4e\u68d9g
	testfinexit

    }]



} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"

test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
    # Bug #219314 - if we don't free escape encodings correctly on channel
    # closure, we go boom
    set file [makeFile {
	encoding system iso2022-jp
	set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
	puts $a
    } iso2022.tcl]
    set f [open "|[list [interpreter] $file]"]
    fconfigure $f -encoding iso2022-jp
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
	{4F21 4F53}

	{50 21 73 7E}
	{7421 7426}
    } {
	if {[llength $range] == 2} {
	    # for adhoc range. simple {first last}. inclusive.
	    set first [scan [lindex $range 0] %x]
	    set last [scan [lindex $range 1] %x]
	    for {set i $first} {$i <= $last} {incr i} {
		set code $i
		uplevel 1 $command
	    }
	} elseif {[llength $range] == 4} {
	    # for uniform range.
	    set h0 [scan [lindex $range 0] %x]
	    set l0 [scan [lindex $range 1] %x]
	    set hend [scan [lindex $range 2] %x]
	    set lend [scan [lindex $range 3] %x]
	    for {set hi $h0} {$hi <= $hend} {incr hi} {
		for {set lo $l0} {$lo <= $lend} {incr lo} {
		    set code [expr {$hi << 8 | ($lo & 0xff)}]
		    uplevel 1 $command
		}
	    }
	} else {







<
|






|
<
<
<







468
469
470
471
472
473
474

475
476
477
478
479
480
481
482



483
484
485
486
487
488
489
	{4F21 4F53}

	{50 21 73 7E}
	{7421 7426}
    } {
	if {[llength $range] == 2} {
	    # for adhoc range. simple {first last}. inclusive.

	    scan $range %x%x first last
	    for {set i $first} {$i <= $last} {incr i} {
		set code $i
		uplevel 1 $command
	    }
	} elseif {[llength $range] == 4} {
	    # for uniform range.
	    scan $range %x%x%x%x h0 l0 hend lend



	    for {set hi $h0} {$hi <= $hend} {incr hi} {
		for {set lo $l0} {$lo <= $lend} {incr lo} {
		    set code [expr {$hi << 8 | ($lo & 0xff)}]
		    uplevel 1 $command
		}
	    }
	} else {
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547

548
549
550
551
552
553
554
555
556
557
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





	# For more readable (easy to analyze) output.
	set code [lindex $la 0]
	binary scan [lindex $la 1] H* expected
	binary scan [lindex $lb 1] H* got
	lappend diff [list $code $expected $got]
    }
    set diff
}

# Create char tables.
cd [temporaryDirectory]
foreach enc {cp932 euc-jp iso2022-jp} {
    set f [open $enc.chars w]
    fconfigure $f -encoding binary
    foreach-jisx0208 code {
	puts $f [format "%04X %s" $code [gen-jisx0208-$enc $code]]
    }
    close $f
}
# shiftjis == cp932 for jisx0208.
file copy -force cp932.chars shiftjis.chars

set NUM 0
foreach from {cp932 shiftjis euc-jp iso2022-jp} {
    foreach to {cp932 shiftjis euc-jp iso2022-jp} {
	test encoding-25.[incr NUM] "jisx0208 $from => $to" {
	    cd [temporaryDirectory]

	    set f [open $from.chars]
	    fconfigure $f -encoding $from
	    set out [open $from.$to.tcltestout w]
	    fconfigure $out -encoding $to
	    puts -nonewline $out [read $f]
	    close $out
	    close $f
	    
	    # then compare $to.chars <=> $from.to.tcltestout as binary.
	    set fa [open $to.chars]
	    fconfigure $fa -encoding binary
	    set fb [open $from.$to.tcltestout]
	    fconfigure $fb -encoding binary
	    set diff [channel-diff $fa $fb]


	    close $fa
	    close $fb
	    
	    # Difference should be empty.
	    set diff
	} {}
    }
}

testConstraint testgetdefenc [llength [info commands testgetdefenc]]

test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints {
    testgetdefenc 
} -setup {
     set origDir [testgetdefenc]
     testsetdefenc slappy
} -body {
     testgetdefenc
} -cleanup {
     testsetdefenc $origDir
} -result slappy

file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===

# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

}
runtests

}

# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return











|


















|

>







<

|
<
|
<
|
>
>


|
<
<
<



<
<

|

|
|

|

|





|
|
>









>
>
>
>
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554

555
556

557

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

	# For more readable (easy to analyze) output.
	set code [lindex $la 0]
	binary scan [lindex $la 1] H* expected
	binary scan [lindex $lb 1] H* got
	lappend diff [list $code $expected $got]
    }
    return $diff
}

# Create char tables.
cd [temporaryDirectory]
foreach enc {cp932 euc-jp iso2022-jp} {
    set f [open $enc.chars w]
    fconfigure $f -encoding binary
    foreach-jisx0208 code {
	puts $f [format "%04X %s" $code [gen-jisx0208-$enc $code]]
    }
    close $f
}
# shiftjis == cp932 for jisx0208.
file copy -force cp932.chars shiftjis.chars

set NUM 0
foreach from {cp932 shiftjis euc-jp iso2022-jp} {
    foreach to {cp932 shiftjis euc-jp iso2022-jp} {
	test encoding-25.[incr NUM] "jisx0208 $from => $to" -setup {
	    cd [temporaryDirectory]
	} -body {
	    set f [open $from.chars]
	    fconfigure $f -encoding $from
	    set out [open $from.$to.tcltestout w]
	    fconfigure $out -encoding $to
	    puts -nonewline $out [read $f]
	    close $out
	    close $f

	    # then compare $to.chars <=> $from.to.tcltestout as binary.
	    set fa [open $to.chars rb]

	    set fb [open $from.$to.tcltestout rb]

	    channel-diff $fa $fb
	    # Difference should be empty.
	} -cleanup {
	    close $fa
	    close $fb
	} -result {}



    }
}



test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints {
    testgetdefenc
} -setup {
    set origDir [testgetdefenc]
    testsetdefenc slappy
} -body {
    testgetdefenc
} -cleanup {
    testsetdefenc $origDir
} -result slappy

file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===

# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
# this file.

}
runtests

}

# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tools/tcltk-man2html-utils.tcl.

621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
## build a cross-reference link if appropriate
##
proc cross-reference {ref} {
    global manual remap_link_target
    global ensemble_commands exclude_refs_map exclude_when_followed_by_map
    set manname $manual(name)
    set mantail $manual(tail)
    if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref]} {
	regexp {^\w+} $ref lref
	##
	## apply a link remapping if available
	##
	if {[info exists remap_link_target($lref)]} {
	    set lref $remap_link_target($lref)
	}







|







621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
## build a cross-reference link if appropriate
##
proc cross-reference {ref} {
    global manual remap_link_target
    global ensemble_commands exclude_refs_map exclude_when_followed_by_map
    set manname $manual(name)
    set mantail $manual(tail)
    if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref] || [string match "Itcl_*" $ref] || [string match "Tdbc_*" $ref]} {
	regexp {^\w+} $ref lref
	##
	## apply a link remapping if available
	##
	if {[info exists remap_link_target($lref)]} {
	    set lref $remap_link_target($lref)
	}
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
	puts stderr "multiple cross reference to $ref in $manref from $manual(wing-file)/$mantail"
	return $ref
    }
    ##
    ## exceptions, sigh, to the rule
    ##
    if {[info exists exclude_when_followed_by_map($mantail)]} {
	upvar 1 tail tail
	set following_word [lindex [regexp -inline {\S+} $tail] 0]
	foreach {this that} $exclude_when_followed_by_map($mantail) {
	    # only a ref if $this is not followed by $that
	    if {$lref eq $this && [string match $that* $following_word]} {
		return $ref
	    }
	}







|







701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
	puts stderr "multiple cross reference to $ref in $manref from $manual(wing-file)/$mantail"
	return $ref
    }
    ##
    ## exceptions, sigh, to the rule
    ##
    if {[info exists exclude_when_followed_by_map($mantail)]} {
	upvar 1 text tail
	set following_word [lindex [regexp -inline {\S+} $tail] 0]
	foreach {this that} $exclude_when_followed_by_map($mantail) {
	    # only a ref if $this is not followed by $that
	    if {$lref eq $this && [string match $that* $following_word]} {
		return $ref
	    }
	}
754
755
756
757
758
759
760
761
762
763


764
765
766
767
768
769
770
	## find where each item lives - EXPENSIVE - and accumulate a list
	##
	unset -nocomplain offsets
	foreach {name pattern} {
	    anchor     {<A }	end-anchor {</A>}
	    quote      {``}	end-quote  {''}
	    bold       {<B>}	end-bold   {</B>}
	    tcl        {Tcl_}
	    tk         {Tk_}
	    ttk	       {Ttk_}


	    Tcl1       {Tcl manual entry}
	    Tcl2       {Tcl overview manual entry}
	    url	       {http://}
	} {
	    set o [string first $pattern $text]
	    if {[set offset($name) $o] >= 0} {
		set invert($o) $name







|
|
|
>
>







754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
	## find where each item lives - EXPENSIVE - and accumulate a list
	##
	unset -nocomplain offsets
	foreach {name pattern} {
	    anchor     {<A }	end-anchor {</A>}
	    quote      {``}	end-quote  {''}
	    bold       {<B>}	end-bold   {</B>}
	    c.tcl      {Tcl_}
	    c.tk       {Tk_}
	    c.ttk      {Ttk_}
	    c.tdbc     {Tdbc_}
	    c.itcl     {Itcl_}
	    Tcl1       {Tcl manual entry}
	    Tcl2       {Tcl overview manual entry}
	    url	       {http://}
	} {
	    set o [string first $pattern $text]
	    if {[set offset($name) $o] >= 0} {
		set invert($o) $name
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
845
846
847
848
849
850
851
852
853
854
855
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
		switch -exact -- $invert([lindex $offsets 1]) {
		    end-quote {
			append result [string range $text 0 [expr {$offset(quote)-1}]]
			set body [string range $text [expr {$offset(quote)+2}] \
				      [expr {$offset(end-quote)-1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-quote)+2}] end]
			set tail $text
			append result `` [cross-reference $body] ''
			continue
		    }
		    bold -
		    anchor {
			append result [string range $text \
				      0 [expr {$offset(end-quote)+1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-quote)+2}] end]
			continue
		    }
		}
		return [reference-error "Uncaught quote case" $text]
	    }
	    bold {
		if {$offset(end-bold) < 0} {
		    return [append result $text]
		}
		if {$invert([lindex $offsets 1]) in {tcl tk ttk}} {
		    set offsets [lreplace $offsets 1 1]
		}
		switch -exact -- $invert([lindex $offsets 1]) {
		    url - end-bold {
			append result \
			    [string range $text 0 [expr {$offset(bold)-1}]]
			set body [string range $text [expr {$offset(bold)+3}] \
				      [expr {$offset(end-bold)-1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-bold)+4}] end]
			set tail $text
			regsub {http://[\w/.]+} $body {<A HREF="&">&</A>} body
			append result <B> [cross-reference $body] </B>
			continue
		    }
		    anchor {
			append result \
			    [string range $text 0 [expr {$offset(end-bold)+3}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-bold)+4}] end]
			continue
		    }
		    default {
			return [reference-error "Uncaught bold case" $text]
		    }
		}
	    }
	    tk {
		append result [string range $text 0 [expr {$offset(tk)-1}]]
		if {![regexp -indices -start $offset(tk) {Tk_\w+} $text range]} {
		    return [reference-error "Tk regexp failed" $text]
		}
		set body [string range $text {*}$range]
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		set tail $text
		append result [cross-reference $body]
		continue
	    }
	    ttk {
		append result [string range $text 0 [expr {$offset(ttk)-1}]]
		if {![regexp -indices -start $offset(ttk) {Ttk_\w+} $text range]} {
		    return [reference-error "Ttk regexp failed" $text]
		}
		set body [string range $text {*}$range]
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		set tail $text
		append result [cross-reference $body]
		continue
	    }
	    tcl {
		append result [string range $text 0 [expr {$offset(tcl)-1}]]
		if {![regexp -indices -start $offset(tcl) {Tcl_\w+} $text range]} {
		    return [reference-error "Tcl regexp failed" $text]
		}
		set body [string range $text {*}$range]
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		set tail $text
		append result [cross-reference $body]
		continue
	    }
	    Tcl1 -
	    Tcl2 {
		set off [lindex $offsets 0]
		append result [string range $text 0 [expr {$off-1}]]
		set text [string range $text[set text ""] [expr {$off+3}] end]
		set tail $text
		append result [cross-reference Tcl]
		continue
	    }
	    url {
		set off [lindex $offsets 0]
		append result [string range $text 0 [expr {$off-1}]]
		regexp -indices -start $off {http://[\w/.]+} $text range
		set url [string range $text {*}$range]
		append result "<A HREF=\"$url\">" $url "</A>"
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		continue
	    }
	    end-anchor -
	    end-bold -
	    end-quote {
		return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
	    }
	}
    }
}
##
## process formatting directives







<



|
<













|










<
















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



<



|
<



<













|
<
<







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
845
846
847
848
849
850
851
852
853
854
855
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
		switch -exact -- $invert([lindex $offsets 1]) {
		    end-quote {
			append result [string range $text 0 [expr {$offset(quote)-1}]]
			set body [string range $text [expr {$offset(quote)+2}] \
				      [expr {$offset(end-quote)-1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-quote)+2}] end]

			append result `` [cross-reference $body] ''
			continue
		    }
		    bold - anchor {

			append result [string range $text \
				      0 [expr {$offset(end-quote)+1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-quote)+2}] end]
			continue
		    }
		}
		return [reference-error "Uncaught quote case" $text]
	    }
	    bold {
		if {$offset(end-bold) < 0} {
		    return [append result $text]
		}
		if {[string match "c.*" $invert([lindex $offsets 1])]} {
		    set offsets [lreplace $offsets 1 1]
		}
		switch -exact -- $invert([lindex $offsets 1]) {
		    url - end-bold {
			append result \
			    [string range $text 0 [expr {$offset(bold)-1}]]
			set body [string range $text [expr {$offset(bold)+3}] \
				      [expr {$offset(end-bold)-1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-bold)+4}] end]

			regsub {http://[\w/.]+} $body {<A HREF="&">&</A>} body
			append result <B> [cross-reference $body] </B>
			continue
		    }
		    anchor {
			append result \
			    [string range $text 0 [expr {$offset(end-bold)+3}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-bold)+4}] end]
			continue
		    }
		    default {
			return [reference-error "Uncaught bold case" $text]
		    }
		}
	    }












	    c.tk - c.ttk - c.tcl - c.tdbc - c.itcl {
		append result [string range $text 0 \





				   [expr {[lindex $offsets 0]-1}]]






		regexp -indices -start [lindex $offsets 0] {\w+} $text range


		set body [string range $text {*}$range]
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]

		append result [cross-reference $body]
		continue
	    }
	    Tcl1 - Tcl2 {

		set off [lindex $offsets 0]
		append result [string range $text 0 [expr {$off-1}]]
		set text [string range $text[set text ""] [expr {$off+3}] end]

		append result [cross-reference Tcl]
		continue
	    }
	    url {
		set off [lindex $offsets 0]
		append result [string range $text 0 [expr {$off-1}]]
		regexp -indices -start $off {http://[\w/.]+} $text range
		set url [string range $text {*}$range]
		append result "<A HREF=\"$url\">" $url "</A>"
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		continue
	    }
	    end-anchor - end-bold - end-quote {


		return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
	    }
	}
    }
}
##
## process formatting directives

Changes to tools/tcltk-man2html.tcl.

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
    global build_tcl tcltkdir tcldir
    if {$type ni {n 3}} {
	error "unknown type \"$type\": must be 3 or n"
    }
    if {!$build_tcl} return
    set result {}
    foreach {dir name} $args {
	set globpat $tcltkdir/$tcldir/pkgs/$dir/doc/*.$type
	if {![llength [glob -nocomplain $globpat]]} {
	    # Fallback for manpages generated using doctools
	    set globpat $tcltkdir/$tcldir/pkgs/$dir/doc/man/*.$type
	    if {![llength [glob -nocomplain $globpat]]} {
		continue
	    }
	}


	switch $type {
	    n {
		set title "$name Package Commands"



		set dir [string totitle $dir]Cmd
		set desc \
		    "The additional commands provided by the $name package."
	    }
	    3 {
		set title "$name Package Library"



		set dir [string totitle $dir]Lib
		set desc \
		    "The additional C functions provided by the $name package."
	    }
	}
	lappend result [list $globpat $title $dir $desc]
    }







|


|




>
>



>
>
>






>
>
>







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
    global build_tcl tcltkdir tcldir
    if {$type ni {n 3}} {
	error "unknown type \"$type\": must be 3 or n"
    }
    if {!$build_tcl} return
    set result {}
    foreach {dir name} $args {
	set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/*.$type
	if {![llength [glob -nocomplain $globpat]]} {
	    # Fallback for manpages generated using doctools
	    set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/man/*.$type
	    if {![llength [glob -nocomplain $globpat]]} {
		continue
	    }
	}
	regexp "pkgs/$dir(.*)/doc$" [glob $tcltkdir/$tcldir/pkgs/$dir*/doc] \
	    -> version
	switch $type {
	    n {
		set title "$name Package Commands"
		if {$version ne ""} {
		    append title ", version $version"
		}
		set dir [string totitle $dir]Cmd
		set desc \
		    "The additional commands provided by the $name package."
	    }
	    3 {
		set title "$name Package Library"
		if {$version ne ""} {
		    append title ", version $version"
		}
		set dir [string totitle $dir]Lib
		set desc \
		    "The additional C functions provided by the $name package."
	    }
	}
	lappend result [list $globpat $title $dir $desc]
    }
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
set excluded_pages {case menubar pack-old}
set forced_index_pages {GetDash}
set process_first_patterns {*/ttk_widget.n */options.n}
set ensemble_commands {
    after array binary chan clock dde dict encoding file history info interp
    memory namespace package registry self string trace update zlib
    clipboard console font grab grid image option pack place selection tk
    tkwait ttk::style winfo wm
}
array set remap_link_target {
    stdin  Tcl_GetStdChannel
    stdout Tcl_GetStdChannel
    stderr Tcl_GetStdChannel
    style  ttk::style
    {style map} ttk::style







|







808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
set excluded_pages {case menubar pack-old}
set forced_index_pages {GetDash}
set process_first_patterns {*/ttk_widget.n */options.n}
set ensemble_commands {
    after array binary chan clock dde dict encoding file history info interp
    memory namespace package registry self string trace update zlib
    clipboard console font grab grid image option pack place selection tk
    tkwait ttk::style winfo wm itcl::delete itcl::find itcl::is
}
array set remap_link_target {
    stdin  Tcl_GetStdChannel
    stdout Tcl_GetStdChannel
    stderr Tcl_GetStdChannel
    style  ttk::style
    {style map} ttk::style
830
831
832
833
834
835
836


837
838
839
840
841
842
843
    Tcl_ObjType Tcl_RegisterObjType
    Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
    errorinfo 	env
    errorcode 	env
    tcl_pkgpath env
    Tcl_Command Tcl_CreateObjCommand
    Tcl_CmdProc Tcl_CreateObjCommand


    Tcl_Channel Tcl_OpenFileChannel
    Tcl_WideInt Tcl_NewIntObj
    Tcl_ChannelType Tcl_CreateChannel
    Tcl_DString Tcl_DStringInit
    Tcl_Namespace Tcl_AppendExportList
    Tcl_Object  Tcl_NewObjectInstance
    Tcl_Class   Tcl_GetObjectAsClass







>
>







838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
    Tcl_ObjType Tcl_RegisterObjType
    Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
    errorinfo 	env
    errorcode 	env
    tcl_pkgpath env
    Tcl_Command Tcl_CreateObjCommand
    Tcl_CmdProc Tcl_CreateObjCommand
    Tcl_CmdDeleteProc Tcl_CreateObjCommand
    Tcl_ObjCmdProc Tcl_CreateObjCommand
    Tcl_Channel Tcl_OpenFileChannel
    Tcl_WideInt Tcl_NewIntObj
    Tcl_ChannelType Tcl_CreateChannel
    Tcl_DString Tcl_DStringInit
    Tcl_Namespace Tcl_AppendExportList
    Tcl_Object  Tcl_NewObjectInstance
    Tcl_Class   Tcl_GetObjectAsClass
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
    }
    if {$build_tk} {
	append tcltkdesc "Tk"
	append cmdesc "Tk"
	append appdir "$tkdir"
    }

    # Get the list of packages to try, and what their human-readable
    # names are.
    try {
	set packageDirNameMap {}
	if {$build_tcl} {
	    set f [open $tcltkdir/$tcldir/pkgs/package.list.txt]
	    try {
		foreach line [split [read $f] \n] {
		    if {[string trim $line] eq ""} continue







|
|







949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
    }
    if {$build_tk} {
	append tcltkdesc "Tk"
	append cmdesc "Tk"
	append appdir "$tkdir"
    }

    # Get the list of packages to try, and what their human-readable names
    # are. Note that the package directory list should be version-less.
    try {
	set packageDirNameMap {}
	if {$build_tcl} {
	    set f [open $tcltkdir/$tcldir/pkgs/package.list.txt]
	    try {
		foreach line [split [read $f] \n] {
		    if {[string trim $line] eq ""} continue