tcl.cc

rtpmon-1.0a7.tar.gz for UNIX like

/*
 * Copyright (c) 1993-1995, 1996 Regents of the University of California.
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *      This product includes software developed by the University of
 *      California, Berkeley and the Network Research Group at
 *      Lawrence Berkeley Laboratory.
 * 4. Neither the name of the University nor of the Laboratory may be used
 *    to endorse or promote products derived from this software without
 *    specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 *
 * $Id: Tcl.cc,v 1.3 1996/10/23 06:27:34 aswan Exp $
 */



#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <ctype.h>
#include <tcl.h>
#ifdef _AIX
#include <strings.h>
#endif
#ifndef NO_TK
#include <tk.h>
#endif
#include "Tcl.h"

Tcl Tcl::instance_;

Tcl::Tcl() : tcl_(0), tkmain_(0), application_(0)
{
	bp_ = buffer_;
}

void Tcl::init(const char* application)
{
	init(Tcl_CreateInterp(), application);
}

void Tcl::init(Tcl_Interp* tcl, const char* application)
{
	instance_.tcl_ = tcl;
	instance_.application_ = application;
}

void Tcl::evalf(const char* fmt, ...)
{
        va_list ap;
        va_start(ap, fmt);
        vsprintf(bp_, fmt, ap);
        eval();
}

void Tcl::evalc(const char* s)
{
	int n = strlen(s) + 1;
	if (n < sizeof(buffer_) - (bp_ - buffer_)) {
		char* const p = bp_;
		bp_ += n;
		strcpy(p, s);
		eval(p);
		bp_ = p;
	} else {
		char* p = new char[n + 1];
		strcpy(p, s);
		eval(p);
		delete p;
	}
}

void Tcl::eval(char* s)
{
	int st = Tcl_GlobalEval(tcl_, s);
	if (st != TCL_OK) {
		fprintf(stderr, "%s: \"%s\": %s\n", application_, s, tcl_->result);
		exit(1);
	}
}

void Tcl::eval()
{
	char* p = bp_;
	bp_ = p + strlen(p) + 1;
	/*XXX*/
	if (bp_ >= &buffer_[1024]) {
		fprintf(stderr, "bailing in Tcl::eval\n");
		abort();
	}
	eval(p);
	bp_ = p;
}

void Tcl::resultf(const char* fmt, ...)
{
        va_list ap;
        va_start(ap, fmt);
        vsprintf(bp_, fmt, ap);
        tcl_->result = bp_;
}

void Tcl::error(const char* s)
{
	fprintf(stderr, "%s: \"%s\": %s\n", application_, s, tcl_->result);
	exit(1);
}

#ifndef NO_TK
void Tcl::add_option(const char* name, const char* value)
{
	bp_[0] = toupper(application_[0]);
	sprintf(&bp_[1], "%s.%s", application_ + 1, name);
	Tk_AddOption(tkmain_, bp_, (char*)value, TK_USER_DEFAULT_PRIO + 1);
}

void Tcl::add_default(const char* name, const char* value)
{
	bp_[0] = toupper(application_[0]);
	sprintf(&bp_[1], "%s.%s", application_ + 1, name);
	Tk_AddOption(tkmain_, bp_, (char*)value, TK_STARTUP_FILE_PRIO + 1);
}

const char* Tcl::attr(const char* attr) const
{
	bp_[0] = toupper(application_[0]);
	strcpy(&bp_[1], application_ + 1);
	const char* cp = Tk_GetOption(tkmain_, (char*)attr, bp_);
	if (cp != 0 && *cp == 0)
		cp = 0;
	return (cp);
}
#endif

TclObject* TclObject::all_;
int TclObject::id_;

TclObject::TclObject(const char* name) : name_(0), class_name_(0)
{
	char wrk[32];
	if (name == 0) {
		sprintf(wrk, "_o%d", id_++);
		name = wrk;
	}
	setproc(name);
	next_ = all_;
	all_ = this;
}

TclObject::~TclObject()
{
	Tcl& tcl = Tcl::instance();
	if (!tcl.dark())
		tcl.DeleteCommand(name_);
	TclObject** p;
	for (p = &all_; *p != this; p = &(*p)->next_)
		;
	*p = (*p)->next_;
	delete class_name_;
}

/*
 * go through all the objects and make sure they are defines
 * i.e., this should be run at startup to initialize all the
 * statically defined object classes.  it's okay if we create
 * a command twice in the tcl interpreter -- we'll just "override"
 * the value that we already put there.
 */
void TclObject::define()
{
	Tcl& tcl = Tcl::instance();
	for (TclObject* p = all_; p != 0; p = p->next_) {
		tcl.CreateCommand(p->name(), command, (ClientData)p, 0);
		p->inception();
	}
}

/*
 * Called when object is hooked into tcl, which may be when the
 * object is created (if Tcl has been initialized), or later, when
 * TclObject::define() is called.
 */
void TclObject::inception()
{
}

void TclObject::setproc(const char* name)
{
	Tcl& tcl = Tcl::instance();
	if (name_ != 0 && !tcl.dark()) {
		tcl.DeleteCommand(name_);
		delete name_;
	}
	int n = strlen(name);
	name_ = new char[n + 1];
	strcpy(name_, name);
	if (!tcl.dark()) {
		tcl.CreateCommand(name_, command, (ClientData)this, 0);
		inception();
	}
}

int TclObject::command(ClientData cd, Tcl_Interp*, int ac, char** av)
{
	TclObject* tc = (TclObject*)cd;
	return (tc->command(ac, (const char*const*)av));
}

int TclObject::command(int argc, const char*const* argv)
{
	Tcl& t = Tcl::instance();
	char* cp = t.buffer();
	sprintf(cp, "%s: ", t.application());
	cp += strlen(cp);
	const char* cmd = argv[0];
	if (cmd[0] == '_' && cmd[1] == 'o' && class_name_ != 0)
		sprintf(cp, "\"%s\" (%s): ", class_name_, cmd);
	else
		sprintf(cp, "%s: ", cmd);
	cp += strlen(cp);
	if (argc >= 2)
		sprintf(cp, "no such method (%s)", argv[1]);
	else
		sprintf(cp, "requires additional args");

	t.result(t.buffer());
	return (TCL_ERROR);
}

void TclObject::reset()
{
}

void TclObject::reset_all()
{
	for (TclObject* p = all_; p != 0; p = p->next_)
		p->reset();
}

TclObject* TclObject::lookup(const char* name)
{
	TclObject* p;
	for (p = all_; p != 0; p = p->next_) {
		if (strcmp(p->name_, name) == 0)
			break;
	}
	return (p);
}

void TclObject::class_name(const char* s)
{
	delete class_name_;
	class_name_ = new char[strlen(s) + 1];
	strcpy(class_name_, s);
}

/*
 * delete command - can be used to delete any tcl object
 * (i.e., since ~TclObject is virtual)
 */
class DeleteCommand : public TclObject {
public:
	DeleteCommand() : TclObject("delete") {}
	int command(int argc, const char*const* argv) {
		Tcl& tcl = Tcl::instance();
		if (argc != 2) {
			tcl.result("delete: bad args");
			return (TCL_ERROR);
		}
		TclObject* p = TclObject::lookup(argv[1]);
		if (p == 0) {
			tcl.result("delete: no such object");
			return (TCL_ERROR);
		}
		delete p;
		return (TCL_OK);
	}
} cmd_delete;

/*
 * create command - can be used to create any tcl object
 * via the matcher class.
 * create $classname $id
 */
class CreateCommand : public TclObject {
public:
	CreateCommand() : TclObject("new") {}
	int command(int argc, const char*const* argv) {
		Tcl& tcl = Tcl::instance();
		const char* id;
		if (argc == 2)
			id = 0;
		else if (argc == 3)
			id = argv[2];
		else {
			tcl.result("create: bad args");
			return (TCL_ERROR);
		}
		TclObject* p = Matcher::lookup(argv[1], id);
		if (p != 0)
			tcl.result(p->name());
		return (TCL_OK);
	}
} cmd_create;

Matcher* Matcher::all_;

Matcher::Matcher(const char* classname) : classname_(classname)
{
	next_ = all_;
	all_ = this;
}

TclObject* Matcher::lookup(const char* classname, const char* id)
{
	for (Matcher* p = all_; p != 0; p = p->next_) {
		if (strcasecmp(classname, p->classname_) != 0)
			continue;
		TclObject* o = p->match(id);
		if (o != 0) {
			/* remember an id for error messages */
			if (id != 0) {
				char wrk[80];
				sprintf(wrk, "%s/%s", classname, id);
				o->class_name(wrk);
			} else
				o->class_name(classname);
			return (o);
		}
	}
	return (0);
}

EmbeddedTcl* EmbeddedTcl::all_;

EmbeddedTcl::EmbeddedTcl(int pass, const char* code) : code_(code), pass_(pass)
{
	next_ = all_;
	all_ = this;
}

int EmbeddedTcl::makepass(int pass)
{
	int done = 1;
	Tcl& tcl = Tcl::instance();
	for (EmbeddedTcl* p = all_; p != 0; p = p->next_) {
		if (p->pass_ > pass)
			done = 0;
		else if (p->pass_ == pass)
			tcl.evalc(p->code_);
	}
	return (!done);
}

void EmbeddedTcl::init()
{
	/* make sure all static commands are defined */
	TclObject::define();

	int pass = 0;
	while (makepass(pass))
		++pass;
}