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
|
/*
* pkgooa.c --
*
* This file contains a simple Tcl package "pkgooa" that is intended for
* testing the Tcl dynamic loading facilities.
*
* 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.
*/
#undef STATIC_BUILD
#include "tclOO.h"
#include <string.h>
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Pkgooa_Init declaration is in the source file itself, which is only
* accessed when we are building a library.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
/*
* Prototypes for procedures defined later in this file:
*/
static int Pkgooa_StubsOKObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
|
/*
* pkgooa.c --
*
* This file contains a simple Tcl package "pkgooa" that is intended for
* testing the Tcl dynamic loading facilities.
*
* 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.
*/
#undef STATIC_BUILD
#include "tclOOInt.h"
#include <string.h>
/*
*----------------------------------------------------------------------
*
* Pkgooa_StubsOKObjCmd --
*
* This procedure is invoked to process the "pkgooa_stubsok" Tcl command.
|
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
|
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Object copyObjectInstance(Tcl_Interp *interp,
Tcl_Object source, const char *name, const char *nameSpace)
{
Tcl_Object result;
result = Tcl_CopyObjectInstance(interp, source, name, nameSpace);
if (result == NULL) {
Tcl_AppendResult(interp, "ERROR: copy failed.");
}
return result;
}
copyObjectInstance
/* more entries here, but those are not
* needed for this test-case. */
};
EXTERN int
Pkgooa_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
/* Any TclOO extension which uses stubs, calls
|
<
<
<
<
<
<
<
<
<
<
<
>
|
>
>
>
>
>
>
|
|
|
|
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
|
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static TclOOStubs stubsCopy = {
TCL_STUB_MAGIC,
NULL,
/* It doesn't really matter what implementation of
* Tcl_CopyObjectInstance is put in the "pseudo"
* stub table, since the test-case never actually
* calls this function. All that matters is that it's
* a function with a different memory address than
* the real Tcl_CopyObjectInstance function in Tcl. */
(Tcl_Object (*) (Tcl_Interp *, Tcl_Object, const char *,
const char *t)) Pkgooa_StubsOKObjCmd
/* More entries could be here, but those are not used
* for this test-case. So, being NULL is OK. */
};
extern DLLEXPORT int
Pkgooa_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
/* Any TclOO extension which uses stubs, calls
|
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (tclOOStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO stubs are not inialized");
return TCL_ERROR;
}
/* Test case for Bug [f51efe99a7].
*
* Let tclOOStubsPtr point to an alternate stub table
* (with only a single function, that's enough for
* this test). This way, the function "pkgooa_stubsok"
|
>
>
>
>
|
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (tclOOStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO stubs are not inialized");
return TCL_ERROR;
}
if (tclOOIntStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO internal stubs are not inialized");
return TCL_ERROR;
}
/* Test case for Bug [f51efe99a7].
*
* Let tclOOStubsPtr point to an alternate stub table
* (with only a single function, that's enough for
* this test). This way, the function "pkgooa_stubsok"
|