tbcload/cmpRPkg.c at main · tcltk-depot/tbcload · GitHub

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
/*
 * cmpRPkg.c --
 *
 *  Loader package initialization and command/variable registration (reader).
 *  Tcl 9 modernization:
 *    - No string eval for namespace/export
 *    - Idempotent namespace handling
 *    - Const-correct tables, modern ObjCmd signatures via headers
 *    - Safe string assembly via Tcl_DString
 */

#include <string.h>
#include "cmpInt.h"
#include "proTbcLoad.h"

/* Package identity (TEA) */
static char packageName[] = PACKAGE_NAME;       /* "tbcload" */
static char packageVersion[] = PACKAGE_VERSION; /* e.g. "1.9.0" */

/* Command names (from headers) */
static char evalCommand[] = CMP_EVAL_COMMAND; /* "bceval" */
static char procCommand[] = CMP_PROC_COMMAND; /* "bcproc"  */

/* Command table */
typedef struct CmdTable
{
    const char* cmdName;   /* unqualified, e.g. "bceval" */
    Tcl_ObjCmdProc* proc; /* implementation */
    int exportIt;          /* nonzero => export */
} CmdTable;

/* Forward decls */
static int TbcloadInitInternal(Tcl_Interp* interp, int isSafe);
static int RegisterCommand(Tcl_Interp* interp, const char* nsName, const CmdTable* cmd);

/* Command lists */
static const CmdTable commands[] = {{evalCommand, Tbcload_EvalObjCmd, 1}, {procCommand, Tbcload_ProcObjCmd, 1}, {NULL, NULL, 0}};

static const CmdTable safeCommands[] = {
    {evalCommand, Tbcload_EvalObjCmd, 1}, {procCommand, Tbcload_ProcObjCmd, 1}, {NULL, NULL, 0}};

/* --- helpers --- */
static Tcl_Namespace* GetOrCreateNamespace(Tcl_Interp* interp, const char* nsName)
{
    Tcl_Namespace* ns = Tcl_FindNamespace(interp, nsName, NULL, TCL_GLOBAL_ONLY);
    if (!ns)
    {
        ns = Tcl_CreateNamespace(interp, nsName, NULL, NULL);
    }
    return ns;
}

static int RegisterCommand(Tcl_Interp* interp, const char* nsName, const CmdTable* cmd)
{
    Tcl_Namespace* ns = GetOrCreateNamespace(interp, nsName);
    if (!ns)
        return TCL_ERROR;

    Tcl_DString fq;
    Tcl_DStringInit(&fq);
    Tcl_DStringAppend(&fq, nsName, -1);
    Tcl_DStringAppend(&fq, "::", 2);
    Tcl_DStringAppend(&fq, cmd->cmdName, -1);

    Tcl_CreateObjCommand(interp, Tcl_DStringValue(&fq), cmd->proc, NULL, NULL);
    Tcl_DStringFree(&fq);

    if (cmd->exportIt)
    {
        if (Tcl_Export(interp, ns, cmd->cmdName, 0) != TCL_OK)
            return TCL_ERROR;
    }
    return TCL_OK;
}

/* --- public inits --- */

int Tbcload_Init(Tcl_Interp* interp)
{
    return TbcloadInitInternal(interp, 0);
}

int Tbcload_SafeInit(Tcl_Interp* interp)
{
    return TbcloadInitInternal(interp, 1);
}

/* Common initializer */
static int TbcloadInitInternal(Tcl_Interp* interp, int isSafe)
{
#ifdef USE_TCL_STUBS
    if (!Tcl_InitStubs(interp, TCL_VERSION, 0))
    {
        return TCL_ERROR;
    }
#else
    if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL)
    {
        return TCL_ERROR;
    }
#endif

    /* Initialize loader core (from tbcload) */
    if (TbcloadInit(interp) != TCL_OK)
    { /* internal helper provided by tbcload */
        return TCL_ERROR;
    }

    /* Use packageName "tbcload" also as namespace */
    const char* nsName = packageName;

    const CmdTable* ct = isSafe ? &safeCommands[0] : &commands[0];
    for (; ct->cmdName; ct++)
    {
        if (RegisterCommand(interp, nsName, ct) != TCL_OK)
        {
            return TCL_ERROR;
        }
    }

    return Tcl_PkgProvide(interp, packageName, packageVersion);
}

/* Utility */
const char* TbcloadGetPackageName(void)
{
    return packageName;
}