开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
Tcl.cc
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：32k
源码类别：

通讯编程

开发平台：

Visual C++

Tcl.cc：源码内容
  1. /*
  2.  * Copyright (c) 1993-1995 Regents of the University of California.
  3.  * All rights reserved.
  4.  *
  5.  * Redistribution and use in source and binary forms, with or without
  6.  * modification, are permitted provided that the following conditions
  7.  * are met:
  8.  * 1. Redistributions of source code must retain the above copyright
  9.  *    notice, this list of conditions and the following disclaimer.
  10.  * 2. Redistributions in binary form must reproduce the above copyright
  11.  *    notice, this list of conditions and the following disclaimer in the
  12.  *    documentation and/or other materials provided with the distribution.
  13.  * 3. All advertising materials mentioning features or use of this software
  14.  *    must display the following acknowledgement:
  15.  *      This product includes software developed by the University of
  16.  *      California, Berkeley and the Network Research Group at
  17.  *      Lawrence Berkeley Laboratory.
  18.  * 4. Neither the name of the University nor of the Laboratory may be used
  19.  *    to endorse or promote products derived from this software without
  20.  *    specific prior written permission.
  21.  *
  22.  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
  23.  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  24.  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  25.  * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  26.  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  27.  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  28.  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  29.  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  30.  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  31.  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  32.  * SUCH DAMAGE.
  33.  */
  35. #ifndef lint
  36. static const char rcsid[] =
  37.     "@(#) $Header: /cvsroot/otcl-tclcl/tclcl/Tcl.cc,v 1.76 2007/02/04 01:46:43 tom_henderson Exp $ (LBL)";
  38. #endif
  40. #include "config.h"
  42. #include <stdio.h>
  43. #include <stdlib.h>
  44. #include <string.h>
  45. #include <stdarg.h>
  46. #include <ctype.h>
  47. #include <tcl.h>
  49. #include "tclcl.h"
  50. #include "tclcl-config.h"
  51. #include "tclcl-internal.h"
  52. #include <sys/types.h>
  53. #include <assert.h>
  54. #include "tracedvar.h"
  56. /* WIN32: Moved tk.h to a point after tclcl.h since tclcl.h includes
  57.  * windows.h which grumbles if I load tk.h before it
  58.  */
  59. #ifndef NO_TK
  60. #include <tk.h>
  61. #endif
  63. #define MAX_CODE_TO_DUMP (8*1024)
  65. class InstVar {
  66. protected:
  67. InstVar(const char* name);
  68. public:
  69. virtual ~InstVar();
  70. InstVar* next_;
  71. virtual void set(const char*) = 0;
  72. virtual const char* snget(char *wrk, int wrklen) = 0;
  73. void init(const char* var);
  74. inline const char* name() { return name_; }
  75. inline TracedVar* tracedvar() { return tracedvar_; }
  76. inline void tracedvar(TracedVar* v) { tracedvar_ = v; }
  77. static double time_atof(const char* s);
  78. static double bw_atof(const char* s);
  79. private:
  80. static char* catch_var(ClientData, Tcl_Interp* tcl,
  81.        CONST84 char* name1, CONST84 char* name2, int flags);
  82. protected:
  83. void catch_read(const char* name1, const char* name2);
  84. void catch_write(const char* name1, const char* name2);
  85. void catch_destroy(const char* name1, const char* name2);
  86. const char* name_;
  87. TracedVar* tracedvar_;
  88. };
  89. #define WRK_SMALL_SIZE 32
  90. #define WRK_MEDIUM_SIZE 256
  92. class TracedVarTcl : public TracedVar {
  93. public:
  94. TracedVarTcl(const char* name);
  95. virtual ~TracedVarTcl();
  96. virtual char* value(char* buf, int buflen);
  97. private:
  98. static char* catch_var(ClientData, Tcl_Interp* tcl,
  99.        CONST84 char* name1, CONST84 char* name2, int flags);
  100. protected:
  101. void catch_write(const char* name1, const char*);
  102. void catch_destroy(const char* name1, const char*);
  103. CONST84 char* value_;
  104. };
  107. Tcl Tcl::instance_;
  109. Tcl::Tcl() :
  110. tcl_(0),
  111. tkmain_(0),
  112. application_(0)
  113. {
  114. Tcl_InitHashTable(&objs_, TCL_STRING_KEYS);
  115. bp_ = buffer_;
  116. }
  118. void Tcl::init(const char* application)
  119. {
  120. init(Tcl_CreateInterp(), application);
  121. }
  123. extern EmbeddedTcl et_tclobject;
  125. void Tcl::init(Tcl_Interp* tcl, const char* application)
  126. {
  127. instance_.tcl_ = tcl;
  128. instance_.application_ = application;
  129. et_tclobject.load();
  130. TclClass::init();
  131. }
  133. TclObject* Tcl::lookup(const char* name)
  134. {
  135. /*XXX use tcl hash table */
  136. Tcl_HashEntry* he = Tcl_FindHashEntry(&objs_, (char*)name);
  137. if (he != 0)
  138. return ((TclObject*)Tcl_GetHashValue(he));
  139. return (0);
  140. }
  142. void Tcl::enter(TclObject* o)
  143. {
  144. int nw;
  145. Tcl_HashEntry* he = Tcl_CreateHashEntry(&objs_, (char*)o->name(),
  146. (int*)&nw);
  147. Tcl_SetHashValue(he, (char*)o);
  148. }
  150. void Tcl::remove(TclObject* o)
  151. {
  152. Tcl_HashEntry* he = Tcl_FindHashEntry(&objs_, (char*)o->name());
  153. if (he == 0)
  154. abort();
  156. Tcl_DeleteHashEntry(he);
  157. }
  159. void Tcl::evalc(const char* s)
  160. {
  161. unsigned int n = strlen(s) + 1;
  162. if (n < sizeof(buffer_) - (bp_ - buffer_)) {
  163. char* const p = bp_;
  164. bp_ += n;
  165. strcpy(p, s);
  166. eval(p);
  167. bp_ = p;
  168. } else {
  169. char* p = new char[n + 1];
  170. strcpy(p, s);
  171. eval(p);
  172. delete[] p;
  173. }
  174. }
  176. void Tcl::eval(char* s)
  177. {
  178. int st = Tcl_GlobalEval(tcl_, s);
  179. if (st != TCL_OK) {
  180. int n = strlen(application_) + strlen(s);
  181. if (n > MAX_CODE_TO_DUMP) {
  182. s = "n[code omitted because of length]n";
  183. n = strlen(application_) + strlen(s);
  184. };
  185. char* wrk = new char[n + 80];
  186. sprintf(wrk, "tkerror {%s: %s}", application_, s);
  187. if (Tcl_GlobalEval(tcl_, wrk) != TCL_OK) {
  188. fprintf(stderr, "%s: tcl error on eval of: %sn",
  189. application_, s);
  190. exit(1);
  191. }
  192. delete[] wrk;
  193. //exit(1);
  194. }
  195. }
  197. void Tcl::eval()
  198. {
  199. char* p = bp_;
  200. bp_ = p + strlen(p) + 1;
  201. /*XXX*/
  202. if (bp_ >= &buffer_[1024]) {
  203. fprintf(stderr, "bailing in Tcl::evaln");
  204. assert(0);
  205. exit(1);
  206. }
  207. eval(p);
  208. bp_ = p;
  209. }
  211. void Tcl::error(const char* s)
  212. {
  213. if (strlen(s) > MAX_CODE_TO_DUMP) {
  214. s = "n[code omitted because of length]n";
  215. };
  216. fprintf(stderr, "%s: "%s": %sn", application_, s, tcl_->result);
  217. exit(1);
  218. }
  220. /*XXX should be driven from tcl not C...*/
  221. #ifdef notdef
  222. void Tcl::add_option(const char* name, const char* value)
  223. {
  224. bp_[0] = toupper(application_[0]);
  225. sprintf(&bp_[1], "%s.%s", application_ + 1, name);
  226. Tk_AddOption(tkmain_, bp_, (char*)value, TK_USER_DEFAULT_PRIO + 1);
  227. }
  229. void Tcl::add_default(const char* name, const char* value)
  230. {
  231. bp_[0] = toupper(application_[0]);
  232. sprintf(&bp_[1], "%s.%s", application_ + 1, name);
  233. Tk_AddOption(tkmain_, bp_, (char*)value, TK_STARTUP_FILE_PRIO + 1);
  234. }
  236. const char* Tcl::attr(const char* attr) const
  237. {
  238. bp_[0] = toupper(application_[0]);
  239. strcpy(&bp_[1], application_ + 1);
  240. const char* cp = Tk_GetOption(tkmain_, (char*)attr, bp_);
  241. if (cp != 0 && *cp == 0)
  242. cp = 0;
  243. return (cp);
  244. }
  245. #endif
  248. TclObject::TclObject() : instvar_(0), tracedvar_(0)
  249. {
  250. #if 0
  251. name_[0] = 0;
  252. #else /* ! 0 */
  253. name_ = NULL;
  254. #endif /* 0 */
  255. }
  257. TclObject::~TclObject()
  258. {
  259. delete[] name_;
  260. }
  262. int TclObject::dispatch_static_proc(ClientData clientData,
  263.     Tcl_Interp * /*interp*/,
  264.     int argc, char *argv[])
  265. {
  266. int (*proc)(int argc, const char * const *argv);
  267. proc = (int (*) (int, const char * const *)) clientData;
  268. return ((*proc)(argc - 2, argv + 2));
  269. }
  271. void TclObject::insert(InstVar* p)
  272. {
  273. p->next_ = instvar_;
  274. instvar_ = p;
  275. }
  277. void TclObject::insert(TracedVar* var)
  278. {
  279. var->owner(this);
  280. var->next_ = tracedvar_;
  281. tracedvar_ = var;
  282. }
  284. #ifdef notdef
  285. int TclObject::callback(ClientData cd, Tcl_Interp*, int ac, char** av)
  286. {
  287. TclObject* tc = (TclObject*)cd;
  288. return (tc->command(ac, (const char*const*)av));
  289. }
  290. #endif
  292. void TclObject::name(const char* s)
  293. {
  294. #if 0
  295. // if TCLCL_NAME_LEN we should allow 10^10-1 (almost a billion) objects
  296. if (strlen(s) >= TCLCL_NAME_LEN)
  297. abort();
  298. strcpy(name_, s);
  299. #else /* ! 0 */
  300. delete[] name_;
  301. name_ = new char[strlen(s) + 1];
  302. strcpy(name_, s);
  303. #endif /* 0 */
  304. }
  306. int TclObject::command(int argc, const char*const* argv)
  307. {
  308. #ifdef notdef
  309. Tcl& t = Tcl::instance();
  310. char* cp = t.buffer();
  311. sprintf(cp, "%s: ", t.application());
  312. cp += strlen(cp);
  313. const char* cmd = argv[0];
  314. if (cmd[0] == '_' && cmd[1] == 'o' && class_name_ != 0)
  315. sprintf(cp, ""%s" (%s): ", class_name_, cmd);
  316. else
  317. sprintf(cp, "%s: ", cmd);
  318. cp += strlen(cp);
  319. if (argc >= 2)
  320. sprintf(cp, "no such method (%s)", argv[1]);
  321. else
  322. sprintf(cp, "requires additional args");
  324. t.result(t.buffer());
  325. #endif
  327. if (argc > 2) {
  328. if (strcmp(argv[1], "trace") == 0) {
  329. TclObject* tracer = this;
  330. if (argc > 3)
  331. tracer = TclObject::lookup(argv[3]);
  332. return traceVar(argv[2], tracer);
  333. }
  334. }
  335. return (TCL_ERROR);
  336. }
  338. void
  339. TclObject::create_instvar(const char* var)
  340. {
  341. /*
  342.  * XXX can't use tcl.evalf() because it uses Tcl_GlobalEval
  343.  * and we need to run in the context of the method.
  344.  */
  345. char wrk[256];
  346. sprintf(wrk, "$self instvar %s", var);
  347. Tcl_Eval(Tcl::instance().interp(), wrk);
  348. }
  350. int
  351. TclObject::create_framevar(const char *localName)
  352. {
  353. /*
  354.  * XXX can't use tcl.evalf() because it uses Tcl_GlobalEval
  355.  * and we need to run in the context of the method.
  356.  * 
  357.  * XXX Should add a check to see if we already have this framevar.
  358.  * If so, don't do the following set stuff, otherwise it'll change
  359.  * the correct value to 0.
  360.  */
  361. Tcl_Interp* tcl = Tcl::instance().interp();
  362. CONST84 char *v = (char *) Tcl_GetVar(tcl, (CONST84 char*)localName, 0);
  363. if (v != 0)
  364. return (TCL_OK);
  365. char wrk[WRK_MEDIUM_SIZE];
  366. if (-1 == snprintf(wrk, WRK_MEDIUM_SIZE, "set %s 0", localName))
  367. return TCL_ERROR;
  368. return Tcl_Eval(Tcl::instance().interp(), wrk);
  369. }
  371. // Enumerating through all traced variables, but still use the trace() 
  372. // callback. 
  373. int TclObject::enum_tracedVars()
  374. {
  375. for (InstVar* p = instvar_; p != 0; p = p->next_) {
  376. if (p->tracedvar() && p->tracedvar()->tracer())
  377. p->tracedvar()->tracer()->trace(p->tracedvar());
  378. }
  380. TracedVar* var = tracedvar_;
  381. for ( ;  var != 0;  var = var->next_) 
  382. if (var->tracer()) 
  383. var->tracer()->trace(var);
  384. return TCL_OK;
  385. }
  387. int TclObject::traceVar(const char* varName, TclObject* tracer)
  388. {
  389. // first check for delay-bound variables
  390. int e = delay_bind_dispatch(varName, varName, tracer);
  391. if (e == TCL_OK)  // was delay-bound and is now taken care of
  392. return e;
  394. // now handle regular bound variables
  395. for (InstVar* p = instvar_; p != 0; p = p->next_) {
  396. if (strcmp(p->name(), varName) == 0) {
  397. if (p->tracedvar()) {
  398. p->tracedvar()->tracer(tracer);
  399. tracer->trace(p->tracedvar());
  400. return TCL_OK;
  401. }
  402. Tcl& tcl = Tcl::instance();
  403. tcl.resultf("trace: %s is not a TracedVar", varName);
  404. return TCL_ERROR;
  405. }
  406. }
  408. TracedVar* var = tracedvar_;
  409. for ( ;  var != 0;  var = var->next_) {
  410. if (strcmp(var->name(), varName) == 0) {
  411. var->tracer(tracer);
  412. tracer->trace(var);
  413. return TCL_OK;
  414. }
  415. }
  417. // XXX Introduce the var into OTcl scope before tracing it
  418. OTclObject *otcl_object = 
  419. OTclGetObject(Tcl::instance().interp(), name_);
  420. int result = OTclOInstVarOne(otcl_object, Tcl::instance().interp(),
  421.      "1", (char *)varName, (char *)varName, 0);
  422. if (result == TCL_OK) {
  423. var = new TracedVarTcl(varName);
  424. insert(var);
  425. var->tracer(tracer);
  426. tracer->trace(var);
  427. }
  428. return result;
  429. }
  432. void TclObject::trace(TracedVar*)
  433. {
  434. fprintf(stderr, "SplitObject::trace called in the base class of %sn",
  435. name_);
  436. }
  438. void TclObject::msg_abort(const char *fmt, ...)
  439. {
  440. if (fmt != NULL) {
  441. va_list ap;
  442. va_start(ap, fmt);
  443. vprintf(fmt, ap);
  444. }
  445. ::abort();
  446. }
  450. TclClass* TclClass::all_;
  452. TclClass::TclClass(const char* classname) : class_(0), classname_(classname)
  453. {
  454. if (Tcl::instance().interp()!=NULL) {
  455. // the interpreter already exists!
  456. // this can happen only (?) if the class is created as part
  457. // of a dynamic library
  459. bind();
  460. } else {
  461. // the interpreter doesn't yet exist
  462. // add this class to a linked list that is traversed when
  463. // the interpreter is created
  465. next_ = all_;
  466. all_ = this;
  467. }
  468. }
  470. TclClass::~TclClass()
  471. {
  472. TclClass** p = &all_;
  473. while (*p != this && *p != NULL)
  474. p = &(*p)->next_;
  475. if (*p != NULL) {
  476. *p = (*p)->next_;
  477. }
  478. }
  480. void TclClass::init()
  481. {
  482. for (TclClass* p = all_; p != 0; p = p->next_)
  483. p->bind();
  484. }
  486. int TclClass::dispatch_cmd(ClientData clientData, Tcl_Interp *,
  487.    int argc, CONST84 char *argv[])
  488. {
  489. TclObject* o = (TclObject*)clientData;
  490. return (o->command(argc - 3, argv + 3));
  491. }
  493. int TclClass::create_shadow(ClientData clientData, Tcl_Interp *interp,
  494.     int argc, CONST84 char *argv[])
  495. {
  496. TclClass* p = (TclClass*)clientData;
  497. TclObject* o = p->create(argc, argv);
  498. Tcl& tcl = Tcl::instance();
  499. if (o != 0) {
  500. o->name(argv[0]);
  501. tcl.enter(o);
  502. if (o->init(argc - 2, argv + 2) == TCL_ERROR) {
  503. tcl.remove(o);
  504. delete o;
  505. return (TCL_ERROR);
  506. }
  507. tcl.result(o->name());
  508. OTclAddPMethod(OTclGetObject(interp, argv[0]), "cmd",
  509.        (Tcl_CmdProc *) dispatch_cmd, (ClientData)o, 0);
  510. OTclAddPMethod(OTclGetObject(interp, argv[0]), "instvar",
  511.        (Tcl_CmdProc *) dispatch_instvar, (ClientData)o, 0);
  512. o->delay_bind_init_all();
  513. return (TCL_OK);
  514. } else {
  515. tcl.resultf("new failed while creating object of class %s",
  516.     p->classname_);
  517. return (TCL_ERROR);
  518. }
  519. }
  521. /*
  522.  * Sigh.  Much of this routine duplicates
  523.  * OTclOInstVarMethod.  I did that rather than
  524.  * build and eval the appropriate Tcl code to get
  525.  * the control I wanted over calling my superclass's instvar.
  526.  */
  527. int
  528. TclClass::dispatch_instvar(ClientData /*cd*/, Tcl_Interp* in,
  529.    int argc, CONST84 char *argv[])
  530. {
  531. int i;
  532. int result;
  533. Tcl& tcl = Tcl::instance();
  534. // XXX:
  535. // There seems to be something silly about these next two lines.
  536. // Maybe a TclObject should have a method to return the OTclObject?
  537. OTclObject *otcl_object = OTclGetObject(in, argv[0]);
  538. TclObject* tcl_object = tcl.lookup(argv[0]);
  539. int need_parse = 0;
  541. for (i = 4; i < argc; i++) {
  542. int ac;
  543. CONST84 char **av;
  544. CONST84 char *varName, *localName;
  545. if (strcmp(argv[i], "-parse-part1") == 0) {
  546. need_parse = 1;
  547. continue;
  548. };
  549. result = Tcl_SplitList(in, argv[i], &ac, (const char ***) &av);
  550. if (result != TCL_OK) break;
  551. if (ac == 1) {
  552. varName = localName = av[0];
  553. } else if (ac == 2) {
  554. varName = av[0];
  555. localName = av[1];
  556. } else {
  557. Tcl_ResetResult(in);
  558. Tcl_AppendResult(in, "expected ?inst/local? or ?inst? ?local? but got ",
  559.  argv[i]);
  560. ckfree((char*)av);
  561. result = TCL_ERROR;
  562. break;
  563. };
  564. // handle arrays in instvars if -parse-part1 was specified.
  565. if (need_parse) {
  566. const char *p = strchr (localName, '(');
  567. if (p)
  568. ((char*) localName)[p-localName] = '';
  569. };
  570. if (TCL_OK != (result = tcl_object->delay_bind_dispatch(varName, localName, NULL)))
  571. result = OTclOInstVarOne(otcl_object, in, "1", varName, localName, 0);
  572. ckfree((char*)av);
  573. }
  574. return result;
  575. }
  577. int TclClass::delete_shadow(ClientData, Tcl_Interp*,
  578.    int argc, CONST84 char *argv[])
  579. {
  580. Tcl& tcl = Tcl::instance();
  581. if (argc != 4) {
  582. tcl.result("XXX delete-shadow");
  583. return (TCL_ERROR);
  584. }
  585. TclObject* o = tcl.lookup(argv[0]);
  586. /*
  587.  * Delete shadow if it exists.  Shadow might not exist
  588.  * because of error condition in constructor.
  589.  */
  590. if (o != 0) {
  591. tcl.remove(o);
  592. delete o;
  593. }
  594. return (TCL_OK);
  595. }
  597. void TclClass::bind()
  598. {
  599. Tcl& tcl = Tcl::instance();
  600. tcl.evalf("SplitObject register %s", classname_);
  601. class_ = OTclGetClass(tcl.interp(), (char*)classname_);
  602. OTclAddIMethod(class_, "create-shadow",
  603.        (Tcl_CmdProc *) create_shadow, (ClientData)this, 0);
  604. OTclAddIMethod(class_, "delete-shadow",
  605.        (Tcl_CmdProc *) delete_shadow, (ClientData)this, 0);
  606. otcl_mappings();
  607. }
  609. int TclClass::method(int, const char*const*)
  610. {
  611. /*XXX*/
  612. return (TCL_ERROR);
  613. }
  615. void TclClass::add_method(const char* name)
  616. {
  617. OTclAddPMethod((OTclObject*)class_, (char*)name,
  618.        (Tcl_CmdProc *) dispatch_method, (ClientData)this, 0);
  619. }
  621. int TclClass::dispatch_method(ClientData cd, Tcl_Interp*, int ac, CONST84 char** av)
  622. {
  623. TclClass* tc = (TclClass*)cd;
  624. return (tc->method(ac, (const char*const*)av));
  625. }
  627. void EmbeddedTcl::load()
  628. {
  629. Tcl::instance().evalc(code_);
  630. }
  632. int EmbeddedTcl::load(Tcl_Interp* interp)
  633. {
  634. return Tcl_Eval(interp, (char*)code_);
  635. }
  637. TclCommand::TclCommand(const char* cmd) : name_(cmd)
  638. {
  639. Tcl::instance().CreateCommand(cmd, (Tcl_CmdProc *) dispatch_cmd, (ClientData)this, 0);
  640. }
  642. TclCommand::~TclCommand()
  643. {
  644. Tcl::instance().DeleteCommand(name_);
  645. }
  647. int TclCommand::dispatch_cmd(ClientData clientData, Tcl_Interp*,
  648.    int argc, CONST84 char *argv[])
  649. {
  650. TclCommand* o = (TclCommand*)clientData;
  651. return (o->command(argc, argv));
  652. }
  655. TracedVarTcl::TracedVarTcl(const char* name) : TracedVar(), value_(0)
  656. {
  657. char* s = new char[strlen(name) + 1];
  658. strcpy(s, name);
  659. name_ = s;
  660. Tcl& tcl = Tcl::instance();
  661. Tcl_TraceVar(tcl.interp(), (char*)name,
  662.      TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  663.      (Tcl_VarTraceProc *) catch_var, (ClientData)this);
  664. }
  666. TracedVarTcl::~TracedVarTcl()
  667. {
  668. delete[] (char*)name_;
  669. }
  671. char* TracedVarTcl::value(char* buf, int buflen)
  672. {
  673. if (buf) {
  674. if (value_ != NULL)
  675. strncpy(buf, value_, buflen);
  676. else 
  677. buf[0] = 0;
  678. }
  679. return buf;
  680. }
  682. void TracedVarTcl::catch_write(const char* name1, const char*)
  683. {
  684. if (tracer() == 0)
  685. return;
  686. Tcl_Interp* tcl = Tcl::instance().interp();
  687. value_ = (char *) Tcl_GetVar(tcl, (CONST84 char*)name1, 0);
  688. if (value_ != 0)
  689. tracer()->trace(this);
  690. }
  692. void TracedVarTcl::catch_destroy(const char* /*name1*/, const char*)
  693. {
  694. delete this;
  695. }
  697. char* TracedVarTcl::catch_var(ClientData clientData, Tcl_Interp*,
  698.       CONST84 char* name1, CONST84 char* name2, int flags)
  699. {
  700. TracedVarTcl* p = (TracedVarTcl*)clientData;
  701. if (flags & TCL_TRACE_WRITES)
  702. p->catch_write(name1, name2);
  703. else if ((flags & TCL_TRACE_UNSETS) && (flags & TCL_TRACE_DESTROYED))
  704. p->catch_destroy(name1, name2);
  705. return (0);
  706. }
  709. /*XXX should be easy to extend to arrays*/
  711. char* InstVar::catch_var(ClientData clientData, Tcl_Interp*,
  712.  CONST84 char* name1, CONST84 char* name2, int flags)
  713. {
  714. InstVar* p = (InstVar*)clientData;
  715. if (flags & TCL_TRACE_WRITES)
  716. p->catch_write(name1, name2);
  717. else if (flags & TCL_TRACE_READS)
  718. p->catch_read(name1, name2);
  719. else if ((flags & TCL_TRACE_UNSETS) && (flags & TCL_TRACE_DESTROYED))
  720. p->catch_destroy(name1, name2);
  722. return (0);
  723. }
  725. void InstVar::catch_read(const char* name1, const char* name2)
  726. {
  727. char wrk[WRK_SMALL_SIZE];
  728. Tcl_Interp* tcl = Tcl::instance().interp();
  729. // tcl will copy the value out of wrk
  730. (void)Tcl_SetVar2(tcl, (char*)name1, (char*)name2, (char*)snget(wrk, WRK_SMALL_SIZE), 0);
  731. }
  733. void InstVar::catch_write(const char* name1, const char*)
  734. {
  735. Tcl_Interp* tcl = Tcl::instance().interp();
  736. const char* v = (char *) Tcl_GetVar(tcl, (CONST84 char*)name1, 0);
  737. if (v != 0)
  738. set(v);
  739. }
  741. /*
  742.  * catch_destroy only gets called for instvars allocated on the stack
  743.  * (classinstvars).  Regular instvars are deallocated by TclObject.
  744.  * Gee, I hope there's not a race there.
  745.  */
  746. void InstVar::catch_destroy(const char* /*name1*/, const char*)
  747. {
  748. delete this;
  749. }
  751. InstVar::InstVar(const char* name) : name_(name), tracedvar_(0)
  752. {
  753. Tcl& tcl = Tcl::instance();
  754. Tcl_TraceVar(tcl.interp(), (CONST84 char*)name,
  755.      TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  756.      (Tcl_VarTraceProc *) catch_var, (ClientData)this);
  757. }
  759. InstVar::~InstVar()
  760. {
  761. /*XXX do an untrace?*/
  762. }
  764. /*
  765.  * Initialize the instance variable to the value stored in its class;
  766.  * this way we can easily create defaults for each instance
  767.  * variable that used by C.  We call this routine after the
  768.  * trace is set up so that the trace is invoked and the
  769.  * C variable is initialized.
  770.  */
  771. void InstVar::init(const char* var)
  772. {
  773. char wrk[256];
  774. sprintf(wrk, "$self init-instvar %s", var);
  775. if (Tcl_Eval(Tcl::instance().interp(), wrk) != TCL_OK) {
  776. /*XXX can only happy if TclObject::init-instvar broken */
  777. Tcl::instance().evalf("puts stderr "init-instvar: $errorInfo"");
  778. exit(1);
  779. }
  780. }
  782. class InstVarTclObject : public InstVar {
  783. public:
  784.   InstVarTclObject(const char* name, TclObject** val) 
  785.     : InstVar(name), val_(val) {}
  786.   
  787.   const char* snget(char *wrk, int wrklen) {
  788.     if (-1 == snprintf(wrk, wrklen, "%s", (*val_)->name()))
  789.       abort();
  790.     return (wrk);
  791.   }
  792.   void set(const char* s) {
  793.     *val_ = TclObject::lookup(s);
  794.   }
  795. protected:
  796.   TclObject** val_;
  797. };
  799. class InstVarReal : public InstVar {
  800.  public:
  801.   InstVarReal(const char* name, double* val)
  802. : InstVar(name), val_(val) {}
  803. const char* snget(char *wrk, int wrklen) {
  804. if (-1 == snprintf(wrk, wrklen, "%.17g", *val_))
  805. abort();
  806. return (wrk);
  807. }
  808. void set(const char* s) {
  809. *val_ = atof(s);
  810. }
  811.  protected:
  812. double* val_;
  813. };
  815. class InstVarBandwidth : public InstVarReal {
  816.  public:
  817. InstVarBandwidth(const char* name, double* val)
  818. : InstVarReal(name, val) { }
  819. void set(const char* s) {
  820. *val_ = bw_atof(s);
  821. }
  822. };
  824. class InstVarTime : public InstVarReal {
  825.  public:
  826. InstVarTime(const char* name, double* val)
  827. : InstVarReal(name, val) { }
  828. void set(const char* s) {
  829. *val_ = time_atof(s);
  830. }
  831. };
  833. class InstVarInt : public InstVar {
  834.  public:
  835. InstVarInt(const char* name, int* val)
  836. : InstVar(name), val_(val) {}
  837. const char* snget(char *wrk, int wrklen) {
  838. if (-1 == snprintf(wrk, wrklen, "%d", *val_))
  839. abort();
  840. return (wrk);
  841. }
  842. void set(const char* s) {
  843. *val_ = strtol(s, (char**)0, 0);
  844. }
  845.  protected:
  846. int* val_;
  847. };
  849. class InstVarUInt : public InstVar {
  850.  public:
  851.         InstVarUInt(const char* name, unsigned int* val)
  852. : InstVar(name), val_(val) {}
  853. const char* snget(char *wrk, int wrklen) {
  854. if (-1 == snprintf(wrk, wrklen, "%u", *val_))
  855. abort();
  856. return (wrk);
  857. }
  858. void set(const char* s) {
  859. *val_ = strtoul(s, (char**)0, 0);
  860. }
  861.  protected:
  862. unsigned int* val_;
  863. };
  865. #if defined(HAVE_INT64)
  866. class InstVarInt64 : public InstVar {
  867.  public:
  868. InstVarInt64(const char* name, int64_t* val) 
  869. : InstVar(name), val_(val) {}
  870. const char* snget(char *wrk, int wrklen) {
  871. if (-1 == snprintf(wrk, wrklen, 
  872.    STRTOI64_FMTSTR, *val_))
  873. abort();
  874. return (wrk);
  875. }
  876. void set(const char* s) {
  877. *val_ = STRTOI64(s, (char**)0, 0);
  878. }
  879.  protected:
  880. int64_t* val_;
  881. };
  882. #endif
  884. class InstVarBool : public InstVarInt {
  885.  public:
  886. InstVarBool(const char* var, int* val) : InstVarInt(var, val) {}
  887. void set(const char* s) {
  888. int v;
  890. if (isdigit(*s))
  891. v = atoi(s);
  892. else switch (*s) {
  893. case 't':
  894. case 'T':
  895. v =  1;
  896. break;
  897. default:
  898. v = 0;
  899. break;
  900. }
  902. *val_ = v;
  903. }
  904. };
  906. class InstVarError : public InstVar {
  907.  public:
  908. InstVarError(const char* name, const char* errmsg)
  909. : InstVar(name), errmsg_(errmsg) {}
  910. const char* snget(char *wrk, int wrklen) {
  911. fprintf(stderr, "nERROR: %snn", errmsg_);
  912. abort();
  913. // To make MSVC happy
  914. return NULL;
  915. }
  916. void set(const char* s) {
  917. fprintf(stderr, "nERROR: %snn", errmsg_);
  918. abort();
  919. }
  920.  protected:
  921. const char* errmsg_;
  922. };
  924. class InstVarTracedInt : public InstVar {
  925.  public:
  926. InstVarTracedInt(const char* name, TracedInt* val) : InstVar(name), val_(val) {
  927. tracedvar(val);
  928. }
  929. const char* snget(char *wrk, int wrklen) {
  930. return (val_->value(wrk, wrklen));
  931. }
  932. void set(const char* s) {
  933. *val_ = strtol(s, (char**)0, 0);
  934. }
  935.  protected:
  936. TracedInt* val_;
  937. };
  939. class InstVarTracedReal : public InstVar {
  940.  public:
  941. InstVarTracedReal(const char* name, TracedDouble* val) : InstVar(name), val_(val) { 
  942. tracedvar(val);
  943. }
  944. const char* snget(char *wrk, int wrklen) {
  945. return (val_->value(wrk, wrklen));
  946. }
  947. void set(const char* s) {
  948. *val_ = atof(s);
  949. }
  950.  protected:
  951. TracedDouble* val_;
  952. };
  955. double InstVar::bw_atof(const char* s) 
  956. {
  957. char wrk[32];
  958. char* cp = wrk;
  959. while (isdigit(*s) || *s == 'e' || *s == '+' ||
  960.        *s == '-' || *s == '.')
  961. *cp++ = *s++;
  962. *cp = 0;
  963. double v = atof(wrk);
  964. switch (s[0]) {
  965. case 'k':
  966. case 'K':
  967. v *= 1e3;
  968. break;
  969. case 'm':
  970. case 'M':
  971. v *= 1e6;
  972. break;
  973. case 'g':
  974. case 'G':
  975. v *= 1e9;
  976. break;
  977. case 't':
  978. case 'T':
  979. v *= 1e12;
  980. break;
  981. case 'p':
  982. case 'P':
  983. v *= 1e15;
  984. break;
  985. }
  986. if (s[0] != 0 && s[1] == 'B')
  987. v *= 8;
  989. return (v);
  990. }
  992. double InstVar::time_atof(const char* s)
  993. {
  994. char wrk[32];
  995. char* cp = wrk;
  996. while (isdigit(*s) || *s == 'e' || *s == '+' || *s == '-' || *s == '.')
  997. *cp++ = *s++;
  998. *cp = 0;
  999. double v = atof(wrk);
  1000. switch (*s) {
  1001. case 'm':
  1002. v *= 1e-3;
  1003. break;
  1004. case 'u':
  1005. v *= 1e-6;
  1006. break;
  1007. case 'n':
  1008. v *= 1e-9;
  1009. break;
  1010. case 'p':
  1011. v *= 1e-12;
  1012. break;
  1013. }
  1014. return (v);
  1015. }
  1018. void TclObject::init(InstVar* v, const char* var)
  1019. {
  1020. insert(v);
  1021. v->init(var);
  1022. }
  1024. #define TOB(FUNCTION, C_TYPE, INSTVAR_TYPE, OTHER_STUFF) 
  1025. void TclObject::FUNCTION(const char* var, C_TYPE* val) 
  1026. { 
  1027.   create_instvar(var); 
  1028.   OTHER_STUFF; 
  1029.     init(new INSTVAR_TYPE(var, val), var); 
  1030. }
  1032. TOB(bind, double, InstVarReal, ;)
  1033. TOB(bind_bw, double, InstVarBandwidth, ;)
  1034. TOB(bind_time, double, InstVarTime, ;)
  1035. TOB(bind, int, InstVarInt, ;)
  1036. TOB(bind, unsigned int, InstVarUInt, ;)
  1037. TOB(bind_bool, int, InstVarBool, ;)
  1038. TOB(bind, TclObject*, InstVarTclObject, ;)
  1039. TOB(bind, TracedInt, InstVarTracedInt, val->name(var); val->owner(this);)
  1040. TOB(bind, TracedDouble, InstVarTracedReal, val->name(var); val->owner(this);)
  1042. void TclObject::bind_error(const char* name, const char* errmsg) {
  1043. create_instvar(name);
  1044. insert(new InstVarError(name, errmsg));
  1045. }
  1046. #if defined(HAVE_INT64)
  1047. TOB(bind, int64_t, InstVarInt64, )
  1048. #endif
  1050. int
  1051. TclObject::delay_bind_dispatch(const char* /*varName*/, const char* /*localName*/, TclObject * /*tracer*/)
  1052. {
  1053. return TCL_ERROR;  // terminate search
  1054. }
  1057. void
  1058. TclObject::delay_bind_init_all()
  1059. {
  1060. }
  1062. /*
  1063.  * sigh... I'd like to call both these functions delay_bind_init,
  1064.  * but gcc 2.7.2.3 apparently isn't
  1065.  * distinguishing the two based on signature.
  1066.  */
  1067. void
  1068. TclObject::delay_bind_init_one(const char *varName)
  1069. {
  1070. char wrk[WRK_MEDIUM_SIZE];
  1071. if (-1 == snprintf(wrk, WRK_MEDIUM_SIZE, "$self init-instvar %s", varName))
  1072. abort();
  1073. if (Tcl_Eval(Tcl::instance().interp(), wrk) != TCL_OK)
  1074. abort();
  1075. }
  1077. void
  1078. TclObject::not_a_TracedVar(const char *varName)
  1079. {
  1080. fprintf(stderr, "TclObject: %s is not a TracedVar.n", varName);
  1081. abort();
  1082. }
  1084. void
  1085. TclObject::handle_TracedVar(const char *name, TracedVar *val, TclObject *tracer)
  1086. {
  1087. /*
  1088.  * Remember what the variable is called.
  1089.  * We assume name is a pointer to static storage
  1090.  * and so won't free it.
  1091.  */
  1092. val->name(name);
  1093. // It's not clear that owner is ever used, but we set it anyway
  1094. // for compability.
  1095. val->owner(this);
  1096. // hook the traced var into the tracing system
  1097. val->tracer(tracer);
  1098. tracer->trace(val);
  1099. }
  1101. /*
  1102.  * Traced vars and delay_binding:
  1103.  *
  1104.  * Without delay-binding, tracevars end up linked into
  1105.  * the object's instvar_ and tracedvar_ chains as part of bind().
  1106.  * This info is then used in two places:
  1107.  * - TclObject::enum_tracedVars (to list them all)
  1108.  * - TclObject::traceVar (to see if a given thing we're trying to trace
  1109.  * shoud be, called from TclObject::command's "trace" cmd
  1110.  *
  1111.  * With delay binding this approach doesn't work, since we don't
  1112.  * have InstVar structures in existance at all times.  (This is good---
  1113.  * it saves memory.)  Instead, we call delay_bind_dispatch() to
  1114.  * search the object hierarchy for a delay-bound variable when a script
  1115.  * does "instvar foo_".  This is the only way to search the hierarchy,
  1116.  * so we make it also work the trace command.
  1117.  *
  1118.  * (Design aside:  it would be more elegant to put all the class
  1119.  * variables (i.e., the delay_bound ones) in a class-wide hash and do
  1120.  * a quick lookup on them through the hash table, like what happens
  1121.  * for objects.  Unfortuantely, we can't do this, primarily because we
  1122.  * need offsets into objects (like in Xt), but C++ doesn't allow void
  1123.  * O::* pointers just typed O::*'s, and C++ O::* pointers are REALLY
  1124.  * ugly because they have to handle * multiple inheritance.)
  1125.  *
  1126.  *
  1127.  * There's probably a better way to do this with templates
  1128.  * (but we don't allow templates currently for portability).
  1129.  *
  1130.  * TclObject::delay_bind returns a boolean if it was handled our not
  1131.  * see ~ns-2/agent.cc for an example of how to use delay_bind_init_all
  1132.  * and delay_bind_dispatch.
  1133.  */
  1134. #define TODB(FUNCTION, C_TYPE, INSTVAR_TYPE, TRACEDVAR_CODE) 
  1135. bool 
  1136. TclObject:: FUNCTION (const char* varName, const char* localName, 
  1137.       const char* thisVarName, 
  1138.       C_TYPE *val, TclObject *tracer) 
  1139. { 
  1140. if (strcmp(varName, thisVarName) != 0) return false; 
  1141. if (tracer) { 
  1142. /* traced var request */ 
  1143. TRACEDVAR_CODE; 
  1144. }  else { 
  1145. /* just a binding */ 
  1146. if (TCL_OK != create_framevar(localName)) abort(); 
  1147. (void) (new INSTVAR_TYPE (localName, val)); 
  1148. }; 
  1149. return true; 
  1150. }
  1152. // These macros are quite ugly in that they the xxx_TracedVars
  1153. // reference params of the function above...
  1154. TODB(delay_bind, double, InstVarReal, not_a_TracedVar(thisVarName))
  1155. TODB(delay_bind_bw, double, InstVarBandwidth, not_a_TracedVar(thisVarName))
  1156. TODB(delay_bind_time, double, InstVarTime, not_a_TracedVar(thisVarName))
  1157. TODB(delay_bind, int, InstVarInt, not_a_TracedVar(thisVarName))
  1158. TODB(delay_bind, unsigned int, InstVarUInt, not_a_TracedVar(thisVarName))
  1159. TODB(delay_bind_bool, int, InstVarBool, not_a_TracedVar(thisVarName))
  1160. TODB(delay_bind, TracedInt, InstVarTracedInt, handle_TracedVar(thisVarName,val,tracer))
  1161. TODB(delay_bind, TracedDouble, InstVarTracedReal, handle_TracedVar(thisVarName,val,tracer))
  1163. #if defined(HAVE_INT64)
  1164. TODB(delay_bind, int64_t, InstVarInt64, not_a_TracedVar(thisVarName))
  1165. #endif
  1167. TclObject *
  1168. TclObject::New(const char *className, const char * arg1, ...)
  1169. {
  1170. Tcl_DString buf;
  1171. const char *string;
  1172. Tcl &tcl = Tcl::instance();
  1173. int result;
  1174. va_list ap;
  1176. va_start(ap, arg1);
  1177. Tcl_DStringInit(&buf);
  1178. Tcl_DStringAppendElement(&buf, "new");
  1179. Tcl_DStringAppendElement(&buf, (char*)className);
  1180. string = arg1;
  1181. while (string!=NULL) {
  1182. Tcl_DStringAppendElement(&buf, (char*)string);
  1183. string = va_arg(ap, const char *);
  1184. }
  1185. va_end(ap);
  1187. result = Tcl_Eval(tcl.interp(), Tcl_DStringValue(&buf));
  1188. Tcl_DStringFree(&buf);
  1190. if (result==TCL_ERROR) {
  1191. return NULL;
  1192. }
  1193. else {
  1194. return tcl.lookup(tcl.result());
  1195. }
  1196. }
  1199. int
  1200. TclObject::Delete(TclObject *object)
  1201. {
  1202. Tcl &tcl = Tcl::instance();
  1204. if (object->name()==NULL) {
  1205. // this object does not have a corresponding OTcl object
  1206. delete object;
  1207. tcl.result("");
  1208. return TCL_OK;
  1209. }
  1210. return Tcl_VarEval(tcl.interp(), "delete ", object->name(), NULL);
  1211. }
  1214. int
  1215. TclObject::Invoke(const char *method, ...)
  1216. {
  1217. Tcl_DString buf;
  1218. const char *string;
  1219. Tcl &tcl = Tcl::instance();
  1220. int result;
  1221. va_list ap;
  1223. if (name()==NULL) {
  1224. // this object does not have a corresponding OTcl object
  1225. tcl.result("no otcl object associated with C++ TclObject");
  1226. tcl.add_error("ninvoked from withing TclObject::invoke()");
  1227. return TCL_ERROR;
  1228. }
  1230. va_start(ap, method);
  1231. Tcl_DStringInit(&buf);
  1232. Tcl_DStringAppendElement(&buf, (char*) name());
  1233. Tcl_DStringAppendElement(&buf, (char*) method);
  1234. while ( (string = va_arg(ap, const char *))!=NULL ) {
  1235. Tcl_DStringAppendElement(&buf, (char*) string);
  1236. }
  1237. va_end(ap);
  1239. result = Tcl_Eval(tcl.interp(), Tcl_DStringValue(&buf));
  1240. Tcl_DStringFree(&buf);
  1241. return result;
  1242. }
  1245. int
  1246. TclObject::Invokef(const char *format, ...)
  1247. {
  1248. static char buffer[1024]; /* XXX: individual command should not be
  1249.    * larger than 1023 */
  1251. sprintf(buffer, "%s ", name());
  1252. va_list ap;
  1253. va_start(ap, format);
  1254. vsprintf(&buffer[strlen(buffer)], format, ap);
  1255. return Tcl_Eval(Tcl::instance().interp(), buffer);
  1256. }
  1259. int
  1260. TclArguments::next(const char *&arg)
  1261. {
  1262. if (!more_args()) {
  1263. Tcl::instance().result("too few arguments");
  1264. add_error();
  1265. return TCL_ERROR;
  1266. }
  1268. arg = argv_[current_++];
  1269. if (arg==NULL) {
  1270. Tcl::instance().result("null argument");
  1271. add_error();
  1272. return TCL_ERROR;
  1273. }
  1274. return TCL_OK;
  1275. }
  1278. void
  1279. TclArguments::add_error() const
  1280. {
  1281. Tcl::instance().add_errorf("ninvoked from within '%s %s'",
  1282.    argv_[0], argv_[1]);
  1283. }
  1286. int
  1287. TclArguments::arg(int &value)
  1288. {
  1289. Tcl &tcl = Tcl::instance();
  1290. const char *arg;
  1291. if (next(arg)==TCL_ERROR) {
  1292. return TCL_ERROR;
  1293. }
  1295. if (Tcl_GetInt(tcl.interp(), (char*)arg, &value)==TCL_ERROR) {
  1296. add_error();
  1297. return TCL_ERROR;
  1298. }
  1299. return TCL_OK;
  1300. }
  1303. int
  1304. TclArguments::arg(unsigned int &value)
  1305. {
  1306. int iValue;
  1307. if (arg(iValue)==TCL_ERROR) return TCL_ERROR;
  1308. value = (unsigned int) iValue;
  1309. return TCL_OK;
  1310. }
  1313. int
  1314. TclArguments::arg(unsigned short &value)
  1315. {
  1316. int iValue;
  1317. if (arg(iValue)==TCL_ERROR) return TCL_ERROR;
  1318. value = (unsigned short) iValue;
  1319. return TCL_OK;
  1320. }
  1323. int
  1324. TclArguments::arg(double &value)
  1325. {
  1326. Tcl &tcl = Tcl::instance();
  1327. const char *arg;
  1328. if (next(arg)==TCL_ERROR) {
  1329. return TCL_ERROR;
  1330. }
  1332. if (Tcl_GetDouble(tcl.interp(), (char*) arg, &value)==TCL_ERROR) {
  1333. add_error();
  1334. return TCL_ERROR;
  1335. }
  1336. return TCL_OK;
  1337. }
  1340. int
  1341. TclArguments::arg(TclObject *&value)
  1342. {
  1343. Tcl &tcl = Tcl::instance();
  1344. const char *arg;
  1345. if (next(arg)==TCL_ERROR) {
  1346. return TCL_ERROR;
  1347. }
  1349. value = tcl.lookup(arg);
  1350. if (value==NULL) {
  1351. tcl.resultf("Invalid object name '%s'", arg);
  1352. add_error();
  1353. return TCL_ERROR;
  1354. }
  1355. return TCL_OK;
  1356. }
  1359. int
  1360. TclArguments::arg(const char *&value)
  1361. {
  1362. if (next(value)==TCL_ERROR) {
  1363. return TCL_ERROR;
  1364. }
  1365. return TCL_OK;
  1366. }