Tcl Source Code

Check-in [f3a3b2cd2a]
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki

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

Overview
Comment:Turn pkgb.so into a Tcl9 interoperability test library: Whatever Tcl9 looks like, loading pkgb.so in Tcl 9 should either result in an error-message, either succeed, but never crash. Eliminate unnessarcy static HasStubSupport() and isDigit() functions, just do the same inline.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-4-branch
Files: files | file ages | folders
SHA1: f3a3b2cd2a469655015c957d880771623dbba4a2
User & Date: jan.nijtmans 2012-12-21 08:16:50
Context
2012-12-27
14:41
[Bug 3598580]: Tcl_ListObjReplace may release deleted elements too early

Tests!? Where are the t... check-in: a87c1542ff user: jan.nijtmans tags: core-8-4-branch

2012-12-21
08:36
Make pkgb.so loadable in Tcl 8.4 as well. Eliminate unnessarcy static HasStubSupport() and isDigit(... check-in: 4355f3d4c8 user: jan.nijtmans tags: core-8-5-branch
08:16
Turn pkgb.so into a Tcl9 interoperability test library: Whatever Tcl9 looks like, loading pkgb.so in... check-in: f3a3b2cd2a user: jan.nijtmans tags: core-8-4-branch
2012-12-13
16:11
Restore clarity to macro test. check-in: a598212e22 user: dgp tags: core-8-4-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog. 









1
2
3
4
5
6
7









2012-12-13  Jan Nijtmans  <[email protected]>

	* generic/tcl.h: Fix Tcl_DecrRefCount macro such that it
	doesn't access its objPtr parameter twice any more.

2012-11-14  Donal K. Fellows  <[email protected]>


>
>
>
>
>
>
>
>








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

2012-12-21  Jan Nijtmans  <[email protected]>

	* unix/dltest/pkgb.c:  Turn pkgb.so into a Tcl9 interoperability test
    library: Whatever Tcl9 looks like, loading pkgb.so in Tcl 9 should
    either result in an error-message, either succeed, but never crash.
	* generic/tclStubLib.c: Eliminate unnessarcy static HasStubSupport() and
	isDigit() functions, just do the same inline.

2012-12-13  Jan Nijtmans  <[email protected]>

	* generic/tcl.h: Fix Tcl_DecrRefCount macro such that it
	doesn't access its objPtr parameter twice any more.

2012-11-14  Donal K. Fellows  <[email protected]>
︙︙

Changes to generic/tclStubLib.c.

︙︙
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

#include "tclPort.h"

TclStubs *tclStubsPtr = NULL;
TclPlatStubs *tclPlatStubsPtr = NULL;
TclIntStubs *tclIntStubsPtr = NULL;
TclIntPlatStubs *tclIntPlatStubsPtr = NULL;

static TclStubs *
HasStubSupport(interp)
    Tcl_Interp *interp;
{
    Interp *iPtr = (Interp *) interp;

    if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) {
	return iPtr->stubTable;
    }
    interp->result = "interpreter uses an incompatible stubs mechanism";
    interp->freeProc = TCL_STATIC;
    return NULL;
}

/*
 * Use our own isdigit to avoid linking to libc on windows
 */

static int isDigit(const int c)
{
    return (c >= '0' && c <= '9');
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitStubs --
 *
 *	Tries to initialise the stub table pointers and ensures that the








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

|


<
<
<
<
>








15
16
17
18
19
20
21














22
23
24
25




26
27
28
29
30
31
32
33

#include "tclPort.h"

TclStubs *tclStubsPtr = NULL;
TclPlatStubs *tclPlatStubsPtr = NULL;
TclIntStubs *tclIntStubsPtr = NULL;
TclIntPlatStubs *tclIntPlatStubsPtr = NULL;















/*
 * Use our own ISDIGIT to avoid linking to libc on windows
 */





#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9)

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitStubs --
 *
 *	Tries to initialise the stub table pointers and ensures that the
︙︙
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

#undef Tcl_InitStubs
CONST char *
Tcl_InitStubs(interp, version, exact)
    Tcl_Interp *interp;
    CONST char *version;
    int exact;
{

    CONST char *actualVersion = NULL;
    ClientData pkgData = NULL;
    TclStubs *stubsPtr;

    /*
     * We can't optimize this check by caching tclStubsPtr because that
     * prevents apps from being able to load/unload Tcl dynamically multiple
     * times. [Bug 615304]
     */

    stubsPtr = HasStubSupport(interp);
    if (!stubsPtr) {


	return NULL;
    }

    actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
    if (actualVersion == NULL) {
	return NULL;
    }
    if (exact) {
	CONST char *p = version;
	int count = 0;

	while (*p) {
	    count += !isDigit(*p++);
	}
	if (count == 1) {
	    CONST char *q = actualVersion;

	    p = version;
	    while (*p && (*p == *q)) {
		p++; q++;
	    }
	    if (*p || isDigit(*q)) {
		/* Construct error message */
		stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
		return NULL;
	    }
	} else {
	    actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
	    if (actualVersion == NULL) {








>


|







<
|
>
>












|








|








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

#undef Tcl_InitStubs
CONST char *
Tcl_InitStubs(interp, version, exact)
    Tcl_Interp *interp;
    CONST char *version;
    int exact;
{
    Interp *iPtr = (Interp *) interp;
    CONST char *actualVersion = NULL;
    ClientData pkgData = NULL;
    TclStubs *stubsPtr = iPtr->stubTable;

    /*
     * We can't optimize this check by caching tclStubsPtr because that
     * prevents apps from being able to load/unload Tcl dynamically multiple
     * times. [Bug 615304]
     */


    if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) {
	iPtr->result = "interpreter uses an incompatible stubs mechanism";
	iPtr->freeProc = TCL_STATIC;
	return NULL;
    }

    actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
    if (actualVersion == NULL) {
	return NULL;
    }
    if (exact) {
	CONST char *p = version;
	int count = 0;

	while (*p) {
	    count += !ISDIGIT(*p++);
	}
	if (count == 1) {
	    CONST char *q = actualVersion;

	    p = version;
	    while (*p && (*p == *q)) {
		p++; q++;
	    }
	    if (*p || ISDIGIT(*q)) {
		/* Construct error message */
		stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
		return NULL;
	    }
	} else {
	    actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
	    if (actualVersion == NULL) {
︙︙

Changes to unix/dltest/pkgb.c. 

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

/* 
 * pkgb.c --
 *
 *	This file contains a simple Tcl package "pkgb" that is intended
 *	for testing the Tcl dynamic loading facilities.	 It can be used
 *	in both safe and unsafe interpreters.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tcl.h"

/*
 * Prototypes for procedures defined later in this file:
 */

static int    Pkgb_SubObjCmd _ANSI_ARGS_((ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]));
static int    Pkgb_UnsafeObjCmd _ANSI_ARGS_((ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]));

/*
 *----------------------------------------------------------------------
 *
 * Pkgb_SubObjCmd --
 *
 *	This procedure is invoked to process the "pkgb_sub" Tcl command.
 *	It expects two arguments and returns their difference.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
Pkgb_SubObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj * CONST objv[];	/* Argument objects. */
{
    int first, second;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "num num");
        return TCL_ERROR;
    }
    if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
	    || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
        return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkgb_UnsafeObjCmd --
 *
 *	This procedure is invoked to process the "pkgb_unsafe" Tcl command.
 *	It just returns a constant string.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
Pkgb_UnsafeObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj * CONST objv[];	/* Argument objects. */
{
    Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkgb_Init --
 *
 *	This is a package initialization procedure, which is called
 *	by Tcl when this package is to be added to an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Pkgb_Init(interp)
    Tcl_Interp *interp;		/* Interpreter in which the package is
				 * to be made available. */
{
    int code;

    if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) {

	return TCL_ERROR;
    }


    code = Tcl_PkgProvide(interp, "Pkgb", "2.3");
    if (code != TCL_OK) {
	return code;
    }
    Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkgb_SafeInit --
 *
 *	This is a package initialization procedure, which is called
 *	by Tcl when this package is to be added to an unsafe interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Pkgb_SafeInit(interp)
    Tcl_Interp *interp;		/* Interpreter in which the package is
				 * to be made available. */
{
    int code;

    if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) {

	return TCL_ERROR;
    }


    code = Tcl_PkgProvide(interp, "Pkgb", "2.3");
    if (code != TCL_OK) {
      return code;
    }
    Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, (ClientData) 0,
	    (Tcl_CmdDeleteProc *) NULL);
    return TCL_OK;
}

|


|
|
|



|
|

>







|

|






|
|















|





|



|










|
|















|

|
<







|
|










|

|
|



|
>
|
|
>
>
|















|
|










|

|
|



|
>
|
|
>
>
|

|






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
166
167
168

/*
 * pkgb.c --
 *
 *	This file contains a simple Tcl package "pkgb" that is intended for
 *	testing the Tcl dynamic loading facilities. It can be used in both
 *	safe and unsafe interpreters.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tcl.h"

/*
 * Prototypes for procedures defined later in this file:
 */

static int    Pkgb_SubObjCmd _ANSI_ARGS_((ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int    Pkgb_UnsafeObjCmd _ANSI_ARGS_((ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

/*
 *----------------------------------------------------------------------
 *
 * Pkgb_SubObjCmd --
 *
 *	This procedure is invoked to process the "pkgb_sub" Tcl command. It
 *	expects two arguments and returns their difference.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
Pkgb_SubObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int first, second;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "num num");
	return TCL_ERROR;
    }
    if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
	    || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkgb_UnsafeObjCmd --
 *
 *	This procedure is invoked to process the "pkgb_unsafe" Tcl command. It
 *	just returns a constant string.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
Pkgb_UnsafeObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL);

}

/*
 *----------------------------------------------------------------------
 *
 * Pkgb_Init --
 *
 *	This is a package initialization procedure, which is called by Tcl
 *	when this package is to be added to an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

DLLEXPORT int
Pkgb_Init(interp)
    Tcl_Interp *interp;		/* Interpreter in which the package is to be
				 * made available. */
{
    int code;

    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
	if (Tcl_InitStubs(interp, "8.4-", 0) == NULL) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }
    code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL);
    if (code != TCL_OK) {
	return code;
    }
    Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkgb_SafeInit --
 *
 *	This is a package initialization procedure, which is called by Tcl
 *	when this package is to be added to a safe interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

DLLEXPORT int
Pkgb_SafeInit(interp)
    Tcl_Interp *interp;		/* Interpreter in which the package is to be
				 * made available. */
{
    int code;

    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
	if (Tcl_InitStubs(interp, "8.4-", 0) == NULL) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }
    code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL);
    if (code != TCL_OK) {
	return code;
    }
    Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, (ClientData) 0,
	    (Tcl_CmdDeleteProc *) NULL);
    return TCL_OK;
}

This page was generated in about 0.03s by Fossil 2.24 [f4ffefe708] 2024-04-17 14:02:19