Question

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?

Answer 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
    }
}