问题
I have the following procedure:
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
}
}
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;
}
Makefile:
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\::*]"
Would not create procedures in the bob namespace, but in the global namespace.
Calling namespace current always returns ::.
Any ideas?
回答1:
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.
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
}
}
来源：https://stackoverflow.com/questions/12593389/tcl-rename-of-the-proc-keyword-doesnt-work-in-namespaces-in-tcl-c-library