proc 关键字的 Tcl 重命名在 Tcl C 库中的命名空间中不起作用 [英] Tcl rename of the proc keyword doesn't work in namespaces in Tcl C library
问题描述
我有以下程序:
rename proc _proc
_proc proc {name args body} {
global pass_log_trace
set g_log_trace "0"
if {[info exists pass_log_trace]} {
set g_log_trace $pass_log_trace
}
# simple check if we have double declaration of the same procedure
if {[info procs $name] != ""} {
puts "\nERROR: redeclaration of procedure: $name"
}
_proc $name $args $body
if {$g_log_trace != 0} {
trace add execution $name enter trace_report_enter
trace add execution $name leave trace_report_leave
}
}
它是从使用 Tcl 解释器构建的 C shell 调用的 C 库.shell的代码如下:
It is called from the C shell built using the Tcl interpreter C library. The shell's code is below:
#define _GNU_SOURCE
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <getopt.h>
#include <signal.h>
#include <errno.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <tcl.h>
#include <readline/readline.h>
#include <readline/history.h>
/* Global variables */
static char init_file[256];
static char history_file[256];
static pid_t sfg_pid;
static Tcl_Interp *tcl_interp = NULL;
static int help(char *prog);
/**
* Print the application help.
* @param prog
* @return
*/
static int
help(char *prog)
{
printf("Usage: %s [OPTIONS]\n", prog);
printf("\n");
printf(" -h|-? Print this message and exit.\n");
printf(" --init/-i file Source this file when tcl is started.\n");
printf(" --history/-f file Read/Save history using this existing file.\n");
printf(" --log/-l file Save the Tcl log to the specified file.\n");
printf("\n");
exit(EXIT_SUCCESS);
}
int
main(int argc, char ** argv)
{
const int buf_size = 1024;
const useconds_t sfg_init_tmo_usec = 100000;
char buf[buf_size+1];
int rc;
char *inp = NULL;
char pwd[buf_size+1];
int hfile;
char *prompt = NULL;
int c;
int option_index = 0;
struct option long_options[] = {
/*name arg flag val */
{"help", 0, 0, 'h'},
{"init", 1, 0, 'i'},
{"log", 1, 0, 'l'},
{"configuration", 1, 0, 'c'},
{0, 0, 0, 0}
};
/* default values */
strcpy(init_file, "log_init.tcl");
sfg_pid = 0;
/**
* Options processing...
*/
while ((c = getopt_long (argc, argv, "?hi:f:s:t:p:b:l:c:er",
long_options, &option_index)) != -1) {
switch (c) {
case 'h':
case '?':
help(argv[0]);
break;
case 'i':
strncpy(init_file, optarg, sizeof(init_file)-1);
break;
default:
printf ("?? getopt returned character code %c ??\n", c);
}
}
if (optind < argc) {
printf ("non-option ARGV-elements: ");
while (optind < argc)
printf ("%s ", argv[optind++]);
printf ("\n");
exit(EXIT_FAILURE);
}
/**
* Start and configure tcl interpreter
*/
if ((tcl_interp = Tcl_CreateInterp()) == NULL) {
printf("Could not create Tcl interpreter: %s\n", Tcl_ErrnoMsg(Tcl_GetErrno()));
exit(EXIT_FAILURE);
}
/* allocate a prompt string, default to diag_tcl> , link to TCL variable */
if ((prompt = Tcl_Alloc(256)) == NULL) {
printf("Cannot allocate a prompt variable: %s\n", tcl_interp->result);
exit(EXIT_FAILURE);
}
strncpy(prompt, "diag_tcl> ", 256);
if (Tcl_LinkVar(tcl_interp, "g_shell_prompt", (char *)&prompt, TCL_LINK_STRING) != TCL_OK) {
printf("Unable to link to a prompt global variable: %s\n", tcl_interp->result);
}
/* Source an init file if specified */
if (init_file[0]) {
strcpy(buf, "source ");
strncat(buf, init_file, (buf_size - strlen(buf)));
if ((rc = Tcl_Eval(tcl_interp, buf)) != TCL_OK) {
printf("Tcl Interpreter Error: %s\n", tcl_interp->result);
}
}
/**
* Main single command loop
*/
while (1) {
if (inp) {
free(inp);
inp = NULL;
}
inp = readline(prompt);
if (inp == NULL)
break;
if (*inp == '\n' || *inp == '\r' || *inp == 0) {
continue;
}
if (feof(stdin))
break;
if ((rc = Tcl_Eval(tcl_interp, inp)) != TCL_OK) {
printf("Tcl Interpreter Error: %s\n",
Tcl_GetVar(tcl_interp, "errorInfo", TCL_GLOBAL_ONLY));
}
}
return 0;
}
生成文件:
INC=-I/net/tools/include
LIB=-L/net/tools/lib -L/lib32 -L/usr/lib -m32
BIN=diag.lin
GCC = gcc
all: diag_tclsh
diag_tclsh: diag_tclsh.c
$(GCC) $^ $(INC) $(LIB) -ltcl8.4 -lreadline -lncurses -ltermcap -o $@
install:
cp -f strad /net/tools/bin/$(BIN)
clean:
-rm -f diag_tclsh
这个过程的目的，主要是为代码中的所有过程添加入口和出口点跟踪器.但是，出于某种原因，它还删除了名称空间范围.例如，像这样的代码:
The purpose of this procedure, mainly, is to add entry and exit point tracers to all the procedures in the code. However, for some reason it also removes the namespace scoping. For example, a code like this:
namespace eval bob {
namespace eval joe {
proc proc1 {} {}
}
proc proc2 {} {
puts "proc2"
}
}
puts "Namespace calling [info procs ::bob\::*]"
不会在 bob 命名空间中创建过程，而是在全局命名空间中创建过程.调用 namespace current 总是返回 ::.
Would not create procedures in the bob namespace, but in the global namespace.
Calling namespace current always returns ::.
有什么想法吗?
推荐答案
问题在于标准 proc 创建相对于当前命名空间的命令(当然除非你使用绝对名称)而您的替换将推送一个堆栈帧，该堆栈帧将全局命名空间 (::) 作为其当前 NS.这意味着当您调用 _proc 时，您使用了错误的命名空间.
The problem is that the standard proc creates commands relative to the current namespace (unless you use an absolute name, of course) while your replacement pushes a stack frame that has the global namespace (::) as its current NS. That means that when you call _proc, you're using the wrong namespace.
修复方法是使用 uplevel 1 在调用者的上下文中调用 _proc，或 必要时使用调用者的命名空间限定名称(可通过 uplevel 1 namespace current 发现).在您的情况下，您最好使用第二种技术，因为您还需要将名称用于其他目的(进行存在检查，添加执行跟踪):
The fix is to use uplevel 1 to call _proc in the caller's context, or to qualify the name if necessary with the caller's namespace (discoverable with uplevel 1 namespace current). In your case, you're best off using the second technique as you need the name for other purposes as well (doing the existence check, adding execution traces):
rename proc _proc
_proc proc {name args body} {
global pass_log_trace
set g_log_trace "0"
if {[info exists pass_log_trace]} {
set g_log_trace $pass_log_trace
}
######## ADDED CODE STARTS ########
# Qualify the name if necessary:
if {![string match "::*" $name]} {
set name [uplevel 1 namespace current]::$name
}
######## ADDED CODE ENDS ########
# simple check if we have double declaration of the same procedure
if {[info procs $name] != ""} {
puts "\nERROR: redeclaration of procedure: $name"
}
_proc $name $args $body
if {$g_log_trace != 0} {
trace add execution $name enter trace_report_enter
trace add execution $name leave trace_report_leave
}
}
这篇关于proc 关键字的 Tcl 重命名在 Tcl C 库中的命名空间中不起作用的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
