← Back to branch summary

~ubuntu-branches/debian/sid/itcl4/sid

« back to all changes in this revision

Viewing changes to generic/itcl2TclOO.c

  • Committer: Package Import Robot
  • Author(s): Sergei Golovan
  • Date: 2018-03-06 11:36:54 UTC
  • Revision ID: package-import@ubuntu.com-20180306113654-w3oht8cjhtftrxby
Tags: upstream-4.1.1
Import upstream version 4.1.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
generic/itcl2TclOO.c
 
1
/*
 
2
 * itcl2TclOO.c --
 
3
 *
 
4
 *      This file contains code to create and manage methods.
 
5
 *
 
6
 * Copyright (c) 2007 by Arnulf P. Wiedemann
 
7
 *
 
8
 * See the file "license.terms" for information on usage and redistribution of
 
9
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
10
 */
 
11
 
 
12
#include <tclInt.h>
 
13
#include <tclOOInt.h>
 
14
#include "itclInt.h"
 
15
 
 
16
void *
 
17
Itcl_GetCurrentCallbackPtr(
 
18
    Tcl_Interp *interp)
 
19
{
 
20
    return TOP_CB(interp);
 
21
}
 
22
 
 
23
int
 
24
Itcl_NRRunCallbacks(
 
25
    Tcl_Interp *interp,
 
26
    void *rootPtr)
 
27
{
 
28
    return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
 
29
}
 
30
 
 
31
static int
 
32
CallFinalizePMCall(
 
33
    ClientData data[],
 
34
    Tcl_Interp *interp,
 
35
    int result)
 
36
{
 
37
    Tcl_Namespace *nsPtr = data[0];
 
38
    TclOO_PostCallProc *postCallProc = (TclOO_PostCallProc *)data[1];
 
39
    ClientData clientData = data[2];
 
40
 
 
41
    /*
 
42
     * Give the post-call callback a chance to do some cleanup. Note that at
 
43
     * this point the call frame itself is invalid; it's already been popped.
 
44
     */
 
45
 
 
46
    return postCallProc(clientData, interp, NULL, nsPtr, result);
 
47
}
 
48
 
 
49
static int
 
50
FreeCommand(
 
51
    ClientData data[],
 
52
    Tcl_Interp *interp,
 
53
    int result)
 
54
{
 
55
    Command *cmdPtr = data[0];
 
56
    Proc *procPtr = data[1];
 
57
 
 
58
    ckfree(cmdPtr);
 
59
    procPtr->cmdPtr = NULL;
 
60
 
 
61
    return result;
 
62
}
 
63
 
 
64
static int
 
65
Tcl_InvokeClassProcedureMethod(
 
66
    Tcl_Interp *interp,
 
67
    Tcl_Obj *namePtr,           /* name of the method */
 
68
    Tcl_Namespace *nsPtr,       /* namespace for calling method */
 
69
    ProcedureMethod *pmPtr,     /* method type specific data */
 
70
    int objc,                   /* Number of arguments. */
 
71
    Tcl_Obj *const *objv)       /* Arguments as actually seen. */
 
72
{
 
73
    Proc *procPtr = pmPtr->procPtr;
 
74
    CallFrame *framePtr = NULL;
 
75
    CallFrame **framePtrPtr1 = &framePtr;
 
76
    Tcl_CallFrame **framePtrPtr = (Tcl_CallFrame **)framePtrPtr1;
 
77
    int result;
 
78
 
 
79
    if (procPtr->cmdPtr == NULL) {
 
80
        Command *cmdPtr = ckalloc(sizeof(Command));
 
81
 
 
82
        memset(cmdPtr, 0, sizeof(Command));
 
83
        cmdPtr->nsPtr = (Namespace *) nsPtr;
 
84
        cmdPtr->clientData = NULL;
 
85
        procPtr->cmdPtr = cmdPtr;
 
86
        Tcl_NRAddCallback(interp, FreeCommand, cmdPtr, procPtr, NULL, NULL);
 
87
    }
 
88
 
 
89
    result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
 
90
            (Namespace *) nsPtr, "body of method", Tcl_GetString(namePtr));
 
91
    if (result != TCL_OK) {
 
92
        return result;
 
93
    }
 
94
    /*
 
95
     * Make the stack frame and fill it out with information about this call.
 
96
     * This operation may fail.
 
97
     */
 
98
 
 
99
 
 
100
    result = TclPushStackFrame(interp, framePtrPtr, nsPtr, FRAME_IS_PROC);
 
101
    if (result != TCL_OK) {
 
102
        return result;
 
103
    }
 
104
 
 
105
    framePtr->clientData = NULL;
 
106
    framePtr->objc = objc;
 
107
    framePtr->objv = objv;
 
108
    framePtr->procPtr = procPtr;
 
109
 
 
110
    /*
 
111
     * Give the pre-call callback a chance to do some setup and, possibly,
 
112
     * veto the call.
 
113
     */
 
114
 
 
115
    if (pmPtr->preCallProc != NULL) {
 
116
        int isFinished;
 
117
 
 
118
        result = pmPtr->preCallProc(pmPtr->clientData, interp, NULL,
 
119
                (Tcl_CallFrame *) framePtr, &isFinished);
 
120
        if (isFinished || result != TCL_OK) {
 
121
            Tcl_PopCallFrame(interp);
 
122
            TclStackFree(interp, framePtr);
 
123
            goto done;
 
124
        }
 
125
    }
 
126
 
 
127
    /*
 
128
     * Now invoke the body of the method. Note that we need to take special
 
129
     * action when doing unknown processing to ensure that the missing method
 
130
     * name is passed as an argument.
 
131
     */
 
132
 
 
133
    if (pmPtr->postCallProc) {
 
134
        Tcl_NRAddCallback(interp, CallFinalizePMCall, nsPtr,
 
135
                (Tcl_NRPostProc *)pmPtr->postCallProc, pmPtr->clientData, NULL);
 
136
    }
 
137
    return TclNRInterpProcCore(interp, namePtr, 1, pmPtr->errProc);
 
138
 
 
139
done:
 
140
    return result;
 
141
}
 
142
 
 
143
int
 
144
Itcl_InvokeProcedureMethod(
 
145
    ClientData clientData,      /* Pointer to some per-method context. */
 
146
    Tcl_Interp *interp,
 
147
    int objc,                   /* Number of arguments. */
 
148
    Tcl_Obj *const *objv)       /* Arguments as actually seen. */
 
149
{
 
150
    Tcl_Namespace *nsPtr;
 
151
    Method *mPtr;
 
152
 
 
153
    mPtr = clientData;
 
154
    if (mPtr->declaringClassPtr == NULL) {
 
155
        /* that is the case for typemethods */
 
156
        nsPtr = mPtr->declaringObjectPtr->namespacePtr;
 
157
    } else {
 
158
        nsPtr = mPtr->declaringClassPtr->thisPtr->namespacePtr;
 
159
    }
 
160
 
 
161
    return Tcl_InvokeClassProcedureMethod(interp, mPtr->namePtr, nsPtr,
 
162
            mPtr->clientData, objc, objv);
 
163
}
 
164
 
 
165
static int
 
166
FreeProcedureMethod(
 
167
    ClientData data[],
 
168
    Tcl_Interp *interp,
 
169
    int result)
 
170
{
 
171
    ProcedureMethod *pmPtr = data[0];
 
172
    ckfree(pmPtr);
 
173
    return result;
 
174
}
 
175
 
 
176
int
 
177
Itcl_InvokeEnsembleMethod(
 
178
    Tcl_Interp *interp,
 
179
    Tcl_Namespace *nsPtr,       /* namespace to call the method in */
 
180
    Tcl_Obj *namePtr,           /* name of the method */
 
181
    Tcl_Proc *procPtr,
 
182
    int objc,                   /* Number of arguments. */
 
183
    Tcl_Obj *const *objv)       /* Arguments as actually seen. */
 
184
{
 
185
    ProcedureMethod *pmPtr = ckalloc(sizeof(ProcedureMethod));
 
186
 
 
187
    memset(pmPtr, 0, sizeof(ProcedureMethod));
 
188
    pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
 
189
    pmPtr->procPtr = (Proc *)procPtr;
 
190
    pmPtr->flags = USE_DECLARER_NS;
 
191
 
 
192
    Tcl_NRAddCallback(interp, FreeProcedureMethod, pmPtr, NULL, NULL, NULL);
 
193
    return Tcl_InvokeClassProcedureMethod(interp, namePtr, nsPtr,
 
194
            pmPtr, objc, objv);
 
195
}
 
196
 
 
197
 
 
198
/*
 
199
 * ----------------------------------------------------------------------
 
200
 *
 
201
 * Itcl_PublicObjectCmd, Itcl_PrivateObjectCmd --
 
202
 *
 
203
 *      Main entry point for object invokations. The Public* and Private*
 
204
 *      wrapper functions are just thin wrappers around the main ObjectCmd
 
205
 *      function that does call chain creation, management and invokation.
 
206
 *
 
207
 * ----------------------------------------------------------------------
 
208
 */
 
209
 
 
210
int
 
211
Itcl_PublicObjectCmd(
 
212
    ClientData clientData,
 
213
    Tcl_Interp *interp,
 
214
    Tcl_Class clsPtr,
 
215
    int objc,
 
216
    Tcl_Obj *const *objv)
 
217
{
 
218
    Tcl_Object oPtr = (Tcl_Object)clientData;
 
219
    int result;
 
220
 
 
221
    result = TclOOInvokeObject(interp, oPtr, clsPtr, PUBLIC_METHOD,
 
222
            objc, objv);
 
223
    return result;
 
224
}
 
225
 
 
226
/*
 
227
 * ----------------------------------------------------------------------
 
228
 *
 
229
 * Itcl_NewProcClassMethod --
 
230
 *
 
231
 *      Create a new procedure-like method for a class for Itcl.
 
232
 *
 
233
 * ----------------------------------------------------------------------
 
234
 */
 
235
 
 
236
Tcl_Method
 
237
Itcl_NewProcClassMethod(
 
238
    Tcl_Interp *interp,         /* The interpreter containing the class. */
 
239
    Tcl_Class clsPtr,           /* The class to modify. */
 
240
    TclOO_PreCallProc *preCallPtr,
 
241
    TclOO_PostCallProc *postCallPtr,
 
242
    ProcErrorProc *errProc,
 
243
    ClientData clientData,
 
244
    Tcl_Obj *nameObj,           /* The name of the method, which may be NULL;
 
245
                                 * if so, up to caller to manage storage
 
246
                                 * (e.g., because it is a constructor or
 
247
                                 * destructor). */
 
248
    Tcl_Obj *argsObj,           /* The formal argument list for the method,
 
249
                                 * which may be NULL; if so, it is equivalent
 
250
                                 * to an empty list. */
 
251
    Tcl_Obj *bodyObj,           /* The body of the method, which must not be
 
252
                                 * NULL. */
 
253
    ClientData *clientData2)
 
254
{
 
255
    Tcl_Method result;
 
256
 
 
257
    result = TclOONewProcMethodEx(interp, clsPtr, preCallPtr, postCallPtr,
 
258
           errProc, clientData, nameObj, argsObj, bodyObj,
 
259
           PUBLIC_METHOD | USE_DECLARER_NS, clientData2);
 
260
    return result;
 
261
}
 
262
 
 
263
/*
 
264
 * ----------------------------------------------------------------------
 
265
 *
 
266
 * Itcl_NewProcMethod --
 
267
 *
 
268
 *      Create a new procedure-like method for an object for Itcl.
 
269
 *
 
270
 * ----------------------------------------------------------------------
 
271
 */
 
272
 
 
273
Tcl_Method
 
274
Itcl_NewProcMethod(
 
275
    Tcl_Interp *interp,         /* The interpreter containing the object. */
 
276
    Tcl_Object oPtr,            /* The object to modify. */
 
277
    TclOO_PreCallProc *preCallPtr,
 
278
    TclOO_PostCallProc *postCallPtr,
 
279
    ProcErrorProc *errProc,
 
280
    ClientData clientData,
 
281
    Tcl_Obj *nameObj,           /* The name of the method, which must not be
 
282
                                 * NULL. */
 
283
    Tcl_Obj *argsObj,           /* The formal argument list for the method,
 
284
                                 * which must not be NULL. */
 
285
    Tcl_Obj *bodyObj,           /* The body of the method, which must not be
 
286
                                 * NULL. */
 
287
    ClientData *clientData2)
 
288
{
 
289
    return TclOONewProcInstanceMethodEx(interp, oPtr, preCallPtr, postCallPtr,
 
290
           errProc, clientData, nameObj, argsObj, bodyObj,
 
291
           PUBLIC_METHOD | USE_DECLARER_NS, clientData2);
 
292
}
 
293
 
 
294
/*
 
295
 * ----------------------------------------------------------------------
 
296
 *
 
297
 * Itcl_NewForwardClassMethod --
 
298
 *
 
299
 *      Create a new forwarded method for a class for Itcl.
 
300
 *
 
301
 * ----------------------------------------------------------------------
 
302
 */
 
303
 
 
304
Tcl_Method
 
305
Itcl_NewForwardClassMethod(
 
306
    Tcl_Interp *interp,
 
307
    Tcl_Class clsPtr,
 
308
    int flags,
 
309
    Tcl_Obj *nameObj,
 
310
    Tcl_Obj *prefixObj)
 
311
{
 
312
    return (Tcl_Method)TclOONewForwardMethod(interp, (Class *)clsPtr,
 
313
            flags, nameObj, prefixObj);
 
314
}
 
315
 
 
316
 
 
317
static Tcl_Obj *
 
318
Itcl_TclOOObjectName(
 
319
    Tcl_Interp *interp,
 
320
    Object *oPtr)
 
321
{
 
322
    Tcl_Obj *namePtr;
 
323
 
 
324
    if (oPtr->cachedNameObj) {
 
325
        return oPtr->cachedNameObj;
 
326
    }
 
327
    namePtr = Tcl_NewObj();
 
328
    Tcl_GetCommandFullName(interp, oPtr->command, namePtr);
 
329
    Tcl_IncrRefCount(namePtr);
 
330
    oPtr->cachedNameObj = namePtr;
 
331
    return namePtr;
 
332
}
 
333
 
 
334
int
 
335
Itcl_SelfCmd(
 
336
    ClientData clientData,
 
337
    Tcl_Interp *interp,
 
338
    int objc,
 
339
    Tcl_Obj *const *objv)
 
340
{
 
341
    Interp *iPtr = (Interp *) interp;
 
342
    CallFrame *framePtr = iPtr->varFramePtr;
 
343
    CallContext *contextPtr;
 
344
 
 
345
    if (!Itcl_IsMethodCallFrame(interp)) {
 
346
        Tcl_AppendResult(interp, TclGetString(objv[0]),
 
347
                " may only be called from inside a method", NULL);
 
348
        return TCL_ERROR;
 
349
    }
 
350
 
 
351
    contextPtr = framePtr->clientData;
 
352
 
 
353
    if (objc == 1) {
 
354
        Tcl_SetObjResult(interp, Itcl_TclOOObjectName(interp, contextPtr->oPtr));
 
355
        return TCL_OK;
 
356
    }
 
357
    return TCL_ERROR;
 
358
}
 
359
 
 
360
int
 
361
Itcl_IsMethodCallFrame(
 
362
    Tcl_Interp *interp)
 
363
{
 
364
    Interp *iPtr = (Interp *) interp;
 
365
    CallFrame *framePtr = iPtr->varFramePtr;
 
366
    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
 
367
        return 0;
 
368
    }
 
369
    return 1;
 
370
}
 
371
 
 
372
/* needed as work around for problem in Tcl 8.6.2 TclOO */
 
373
void
 
374
Itcl_IncrObjectRefCount(Tcl_Object ptr) {
 
375
  Object * oPtr = (Object *) ptr;
 
376
  oPtr->refCount++;
 
377
}