Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/trunk/src/cpptcl/CppTcl.cc @ 1379

Last change on this file since 1379 was 1214, checked in by landauf, 17 years ago

merged console-branch back to trunk.
IMPORTANT: update your media directory!

you need TCL to compile. TCL is available here: http://www.tcl.tk/
another option is to check out https://svn.orxonox.net/ogre/tcl8.5.2/ and compile it by yourself. makefiles are in the 'macosx', 'unix' and 'win' subfolders.
FindTCL.cmake searches in the usual locations and in ../libs/tcl8.5.2/

the orxonox console can be activated with numpad-enter. whatever you enter will be parsed by TCL. if TCL doesn't know a command, it gets executed by orxonox.

simple tcl commands are: "puts text" to write "text" into the console, "expr 1+1" to calculate the result of the given expression. just try it by yourself with "puts [expr 1+1]".
[x] means: evaluate x and use the returnvalue as an argument. in this case the returned value is "2" and the resulting command therefore "puts 2".

you can combine orxonox and tcl commands. a simple orxonox command is "log text" that writes text into the console and the logfile. test it with "log [expr 1+1]" to write "2" into all output channels of orxonox. something more advanced: "log [clock seconds]" writes the seconds since 1970 into the logfile. feel free to combine both: "log [clock seconds]: 1+1 is [expr 1+1]"

TCL uses variables. to set a new variable, use "set varname value". you can use the variable wherever you want with $varname. with this we can make the above command a bit more elegant:
set myexpression 1+1
log [clock seconds]: $myexpression is [expr $myexpression]

read more about tcl in the wiki: http://wiki.tcl.tk/

File size: 23.8 KB
Line 
1//
2// Copyright (C) 2004-2006, Maciej Sobczak
3//
4// Permission to copy, use, modify, sell and distribute this software
5// is granted provided this copyright notice appears in all copies.
6// This software is provided "as is" without express or implied
7// warranty, and with no claim as to its suitability for any purpose.
8//
9
10#include "CppTcl.h"
11#include <map>
12#include <sstream>
13#include <iterator>
14
15
16using namespace Tcl;
17using namespace Tcl::details;
18using namespace std;
19using namespace boost;
20
21
22result::result(Tcl_Interp *interp) : interp_(interp) {}
23
24result::operator bool() const
25{
26     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
27
28     int val, cc;
29     cc = Tcl_GetBooleanFromObj(interp_, obj, &val);
30     if (cc != TCL_OK)
31     {
32          throw tcl_error(interp_);
33     }
34
35     return static_cast<bool>(val);
36}
37
38result::operator double() const
39{
40     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
41
42     double val;
43     int cc = Tcl_GetDoubleFromObj(interp_, obj, &val);
44     if (cc != TCL_OK)
45     {
46          throw tcl_error(interp_);
47     }
48
49     return val;
50}
51
52result::operator int() const
53{
54     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
55
56     int val, cc;
57     cc = Tcl_GetIntFromObj(interp_, obj, &val);
58     if (cc != TCL_OK)
59     {
60          throw tcl_error(interp_);
61     }
62
63     return val;
64}
65
66result::operator long() const
67{
68     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
69
70     long val;
71     int cc;
72     cc = Tcl_GetLongFromObj(interp_, obj, &val);
73     if (cc != TCL_OK)
74     {
75          throw tcl_error(interp_);
76     }
77
78     return val;
79}
80
81result::operator string() const
82{
83     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
84     return Tcl_GetString(obj);
85}
86
87result::operator object() const
88{
89     return object(Tcl_GetObjResult(interp_));
90}
91
92
93void details::set_result(Tcl_Interp *interp, bool b)
94{
95     Tcl_SetObjResult(interp, Tcl_NewBooleanObj(b));
96}
97
98void details::set_result(Tcl_Interp *interp, int i)
99{
100     Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
101}
102
103void details::set_result(Tcl_Interp *interp, long i)
104{
105     Tcl_SetObjResult(interp, Tcl_NewLongObj(i));
106}
107
108void details::set_result(Tcl_Interp *interp, double d)
109{
110     Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d));
111}
112
113void details::set_result(Tcl_Interp *interp, string const &s)
114{
115     Tcl_SetObjResult(interp,
116          Tcl_NewStringObj(s.data(), static_cast<int>(s.size())));
117}
118
119void details::set_result(Tcl_Interp *interp, void *p)
120{
121     ostringstream ss;
122     ss << 'p' << p;
123     string s(ss.str());
124
125     Tcl_SetObjResult(interp,
126          Tcl_NewStringObj(s.data(), static_cast<int>(s.size())));
127}
128
129void details::set_result(Tcl_Interp *interp, object const &o)
130{
131     Tcl_SetObjResult(interp, o.get_object());
132}
133
134
135void details::check_params_no(int objc, int required)
136{
137     if (objc < required)
138     {
139          throw tcl_error("Too few arguments.");
140     }
141}
142
143object details::get_var_params(Tcl_Interp *interp,
144     int objc, Tcl_Obj * CONST objv[],
145     int from, policies const &pol)
146{
147     object o;
148     if (pol.variadic_)
149     {
150          check_params_no(objc, from);
151          o.assign(objv + from, objv + objc);
152     }
153     else
154     {
155          check_params_no(objc, from + 1);
156          o.assign(objv[from]);
157     }
158
159     o.set_interp(interp);
160
161     return o;
162}
163
164
165namespace // anonymous
166{
167
168// map of polymorphic callbacks
169typedef map<string, shared_ptr<callback_base> > callback_interp_map;
170typedef map<Tcl_Interp *, callback_interp_map> callback_map;
171
172callback_map callbacks;
173callback_map constructors;
174
175// map of call policies
176typedef map<string, policies> policies_interp_map;
177typedef map<Tcl_Interp *, policies_interp_map> policies_map;
178
179policies_map call_policies;
180
181// map of object handlers
182typedef map<string, shared_ptr<class_handler_base> > class_interp_map;
183typedef map<Tcl_Interp *, class_interp_map> class_handlers_map;
184
185class_handlers_map class_handlers;
186
187
188// helper for finding call policies - returns true when found
189bool find_policies(Tcl_Interp *interp, string const &cmdName,
190     policies_interp_map::iterator &piti)
191{
192     policies_map::iterator pit = call_policies.find(interp);
193     if (pit == call_policies.end())
194     {
195          return false;
196     }
197
198     piti = pit->second.find(cmdName);
199     return piti != pit->second.end();
200}
201
202extern "C"
203int object_handler(ClientData cd, Tcl_Interp *interp,
204     int objc, Tcl_Obj * CONST objv[]);
205
206// helper function for post-processing call policies
207// for both free functions (isMethod == false)
208// and class methods (isMethod == true)
209void post_process_policies(Tcl_Interp *interp, policies &pol,
210     Tcl_Obj * CONST objv[], bool isMethod)
211{
212     // check if it is a factory
213     if (!pol.factory_.empty())
214     {
215          class_handlers_map::iterator it = class_handlers.find(interp);
216          if (it == class_handlers.end())
217          {
218               throw tcl_error(
219                    "Factory was registered for unknown class.");
220          }
221
222          class_interp_map::iterator oit = it->second.find(pol.factory_);
223          if (oit == it->second.end())
224          {
225               throw tcl_error(
226                    "Factory was registered for unknown class.");
227          }
228
229          class_handler_base *chb = oit->second.get();
230
231          // register a new command for the object returned
232          // by this factory function
233          // if everything went OK, the result is the address of the
234          // new object in the 'pXXX' form
235          // - the new command will be created with this name
236
237          Tcl_CreateObjCommand(interp,
238               Tcl_GetString(Tcl_GetObjResult(interp)),
239               object_handler, static_cast<ClientData>(chb), 0);
240     }
241
242     // process all declared sinks
243     // - unregister all object commands that envelopes the pointers
244     for (vector<int>::iterator s = pol.sinks_.begin();
245          s != pol.sinks_.end(); ++s)
246     {
247          if (isMethod == false)
248          {
249               // example: if there is a declared sink at parameter 3,
250               // and the Tcl command was:
251               // % fun par1 par2 PAR3 par4
252               // then the index 3 correctly points into the objv array
253
254               int index = *s;
255               Tcl_DeleteCommand(interp, Tcl_GetString(objv[index]));
256          }
257          else
258          {
259               // example: if there is a declared sink at parameter 3,
260               // and the Tcl command was:
261               // % $p method par1 par2 PAR3 par4
262               // then the index 3 needs to be incremented
263               // in order correctly point into the 4th index of objv array
264
265               int index = *s + 1;
266               Tcl_DeleteCommand(interp, Tcl_GetString(objv[index]));
267          }
268     }
269}
270
271// actual functions handling various callbacks
272
273// generic callback handler
274extern "C"
275int callback_handler(ClientData, Tcl_Interp *interp,
276     int objc, Tcl_Obj * CONST objv[])
277{
278     callback_map::iterator it = callbacks.find(interp);
279     if (it == callbacks.end())
280     {
281          Tcl_SetResult(interp,
282               "Trying to invoke non-existent callback (wrong interpreter?)",
283               TCL_STATIC);
284          return TCL_ERROR;
285     }
286
287     string cmdName(Tcl_GetString(objv[0]));
288     callback_interp_map::iterator iti = it->second.find(cmdName);
289     if (iti == it->second.end())
290     {
291          Tcl_SetResult(interp,
292               "Trying to invoke non-existent callback (wrong cmd name?)",
293               TCL_STATIC);
294          return TCL_ERROR;
295     }
296
297     policies_map::iterator pit = call_policies.find(interp);
298     if (pit == call_policies.end())
299     {
300          Tcl_SetResult(interp,
301               "Trying to invoke callback with no known policies",
302               TCL_STATIC);
303          return TCL_ERROR;
304     }
305
306     policies_interp_map::iterator piti;
307     if (find_policies(interp, cmdName, piti) == false)
308     {
309          Tcl_SetResult(interp,
310               "Trying to invoke callback with no known policies",
311               TCL_STATIC);
312          return TCL_ERROR;
313     }
314
315     policies &pol = piti->second;
316
317     try
318     {
319          iti->second->invoke(interp, objc, objv, pol);
320
321          post_process_policies(interp, pol, objv, false);
322     }
323     catch (exception const &e)
324     {
325          Tcl_SetResult(interp, const_cast<char*>(e.what()), TCL_VOLATILE);
326          return TCL_ERROR;
327     }
328     catch (...)
329     {
330          Tcl_SetResult(interp, "Unknown error.", TCL_STATIC);
331          return TCL_ERROR;
332     }
333
334     return TCL_OK;
335}
336
337// generic "object" command handler
338extern "C"
339int object_handler(ClientData cd, Tcl_Interp *interp,
340     int objc, Tcl_Obj * CONST objv[])
341{
342     // here, client data points to the singleton object
343     // which is responsible for managing commands for
344     // objects of a given type
345
346     class_handler_base *chb = reinterpret_cast<class_handler_base*>(cd);
347
348     // the command name has the form 'pXXX' where XXX is the address
349     // of the "this" object
350
351     string const str(Tcl_GetString(objv[0]));
352     istringstream ss(str);
353     char dummy;
354     void *p;
355     ss >> dummy >> p;
356
357     try
358     {
359          string methodName(Tcl_GetString(objv[1]));
360          policies &pol = chb->get_policies(methodName);
361
362          chb->invoke(p, interp, objc, objv, pol);
363
364          post_process_policies(interp, pol, objv, true);
365     }
366     catch (exception const &e)
367     {
368          Tcl_SetResult(interp, const_cast<char*>(e.what()), TCL_VOLATILE);
369          return TCL_ERROR;
370     }
371     catch (...)
372     {
373          Tcl_SetResult(interp, "Unknown error.", TCL_STATIC);
374          return TCL_ERROR;
375     }
376
377     return TCL_OK;
378}
379
380// generic "constructor" command
381extern "C"
382int constructor_handler(ClientData cd, Tcl_Interp *interp,
383     int objc, Tcl_Obj * CONST objv[])
384{
385     // here, client data points to the singleton object
386     // which is responsible for managing commands for
387     // objects of a given type
388
389     class_handler_base *chb = reinterpret_cast<class_handler_base*>(cd);
390
391     callback_map::iterator it = constructors.find(interp);
392     if (it == constructors.end())
393     {
394          Tcl_SetResult(interp,
395               "Trying to invoke non-existent callback (wrong interpreter?)",
396               TCL_STATIC);
397          return TCL_ERROR;
398     }
399
400     string className(Tcl_GetString(objv[0]));
401     callback_interp_map::iterator iti = it->second.find(className);
402     if (iti == it->second.end())
403     {
404          Tcl_SetResult(interp,
405               "Trying to invoke non-existent callback (wrong class name?)",
406               TCL_STATIC);
407          return TCL_ERROR;
408     }
409
410     policies_interp_map::iterator piti;
411     if (find_policies(interp, className, piti) == false)
412     {
413          Tcl_SetResult(interp,
414               "Trying to invoke callback with no known policies",
415               TCL_STATIC);
416          return TCL_ERROR;
417     }
418
419     policies &pol = piti->second;
420
421     try
422     {
423          iti->second->invoke(interp, objc, objv, pol);
424
425          // if everything went OK, the result is the address of the
426          // new object in the 'pXXX' form
427          // - we can create a new command with this name
428
429          Tcl_CreateObjCommand(interp,
430               Tcl_GetString(Tcl_GetObjResult(interp)),
431               object_handler, static_cast<ClientData>(chb), 0);
432     }
433     catch (exception const &e)
434     {
435          Tcl_SetResult(interp, const_cast<char*>(e.what()), TCL_VOLATILE);
436          return TCL_ERROR;
437     }
438     catch (...)
439     {
440          Tcl_SetResult(interp, "Unknown error.", TCL_STATIC);
441          return TCL_ERROR;
442     }
443
444     return TCL_OK;
445}
446
447} // namespace anonymous
448
449Tcl::details::no_init_type Tcl::no_init;
450
451
452policies & policies::factory(string const &name)
453{
454     factory_ = name;
455     return *this;
456}
457
458policies & policies::sink(int index)
459{
460     sinks_.push_back(index);
461     return *this;
462}
463
464policies & policies::variadic()
465{
466     variadic_ = true;
467     return *this;
468}
469
470policies Tcl::factory(string const &name)
471{
472     return policies().factory(name);
473}
474
475policies Tcl::sink(int index)
476{
477     return policies().sink(index);
478}
479
480policies Tcl::variadic()
481{
482     return policies().variadic();
483}
484
485
486class_handler_base::class_handler_base()
487{
488     // default policies for the -delete command
489     policies_["-delete"] = policies();
490}
491
492void class_handler_base::register_method(string const &name,
493     shared_ptr<object_cmd_base> ocb, policies const &p)
494{
495     methods_[name] = ocb;
496     policies_[name] = p;
497}
498
499policies & class_handler_base::get_policies(string const &name)
500{
501     policies_map_type::iterator it = policies_.find(name);
502     if (it == policies_.end())
503     {
504          throw tcl_error("Trying to use non-existent policy: " + name);
505     }
506
507     return it->second;
508}
509
510
511object::object()
512     : interp_(0)
513{
514     obj_ = Tcl_NewObj();
515     Tcl_IncrRefCount(obj_);
516}
517
518object::object(bool b)
519     : interp_(0)
520{
521     obj_ = Tcl_NewBooleanObj(b);
522     Tcl_IncrRefCount(obj_);
523}
524
525object::object(char const *buf, size_t size)
526     : interp_(0)
527{
528     obj_ = Tcl_NewByteArrayObj(
529          reinterpret_cast<unsigned char const *>(buf),
530          static_cast<int>(size));
531     Tcl_IncrRefCount(obj_);
532}
533
534object::object(double d)
535     : interp_(0)
536{
537     obj_ = Tcl_NewDoubleObj(d);
538     Tcl_IncrRefCount(obj_);
539}
540
541object::object(int i)
542     : interp_(0)
543{
544     obj_ = Tcl_NewIntObj(i);
545     Tcl_IncrRefCount(obj_);
546}
547
548object::object(long l)
549     : interp_(0)
550{
551     obj_ = Tcl_NewLongObj(l);
552     Tcl_IncrRefCount(obj_);
553}
554
555object::object(char const *s)
556     : interp_(0)
557{
558     obj_ = Tcl_NewStringObj(s, -1);
559     Tcl_IncrRefCount(obj_);
560}
561
562object::object(string const &s)
563     : interp_(0)
564{
565     obj_ = Tcl_NewStringObj(s.data(), static_cast<int>(s.size()));
566     Tcl_IncrRefCount(obj_);
567}
568
569object::object(Tcl_Obj *o, bool shared)
570     : interp_(0)
571{
572     init(o, shared);
573}
574
575object::object(object const &other, bool shared)
576     : interp_(other.get_interp())
577{
578     init(other.obj_, shared);
579}
580
581void object::init(Tcl_Obj *o, bool shared)
582{
583     if (shared)
584     {
585          obj_ = o;
586     }
587     else
588     {
589          obj_ = Tcl_DuplicateObj(o);
590     }
591     Tcl_IncrRefCount(obj_);
592}
593
594object::~object()
595{
596     Tcl_DecrRefCount(obj_);
597}
598
599object & object::assign(bool b)
600{
601     Tcl_SetBooleanObj(obj_, b);
602     return *this;
603}
604
605object & object::resize(size_t size)
606{
607     Tcl_SetByteArrayLength(obj_, static_cast<int>(size));
608     return *this;
609}
610
611object & object::assign(char const *buf, size_t size)
612{
613     Tcl_SetByteArrayObj(obj_,
614          reinterpret_cast<unsigned char const *>(buf),
615          static_cast<int>(size));
616     return *this;
617}
618
619object & object::assign(double d)
620{
621     Tcl_SetDoubleObj(obj_, d);
622     return *this;
623}
624
625object & object::assign(int i)
626{
627     Tcl_SetIntObj(obj_, i);
628     return *this;
629}
630
631object & object::assign(long l)
632{
633     Tcl_SetLongObj(obj_, l);
634     return *this;
635}
636
637object & object::assign(char const *s)
638{
639     Tcl_SetStringObj(obj_, s, -1);
640     return *this;
641}
642
643object & object::assign(string const &s)
644{
645     Tcl_SetStringObj(obj_, s.data(), static_cast<int>(s.size()));
646     return *this;
647}
648
649object & object::assign(object const &other)
650{
651     object(other).swap(*this);
652     return *this;
653}
654
655object & object::assign(Tcl_Obj *o)
656{
657     object(o).swap(*this);
658     return *this;
659}
660
661object & object::swap(object &other)
662{
663     std::swap(obj_, other.obj_);
664     std::swap(interp_, other.interp_);
665     return *this;
666}
667
668template <>
669bool object::get<bool>(interpreter &i) const
670{
671     int retVal;
672     int res = Tcl_GetBooleanFromObj(i.get(), obj_, &retVal);
673     if (res != TCL_OK)
674     {
675          throw tcl_error(i.get());
676     }
677
678     return static_cast<bool>(retVal);
679}
680
681template <>
682vector<char> object::get<vector<char> >(interpreter &) const
683{
684     size_t size;
685     char const *buf = get(size);
686     return vector<char>(buf, buf + size);
687}
688
689template <>
690double object::get<double>(interpreter &i) const
691{
692     double retVal;
693     int res = Tcl_GetDoubleFromObj(i.get(), obj_, &retVal);
694     if (res != TCL_OK)
695     {
696          throw tcl_error(i.get());
697     }
698
699     return retVal;
700}
701
702template <>
703int object::get<int>(interpreter &i) const
704{
705     int retVal;
706
707     int res = Tcl_GetIntFromObj(i.get(), obj_, &retVal);
708     if (res != TCL_OK)
709     {
710          throw tcl_error(i.get());
711     }
712
713     return retVal;
714}
715
716template <>
717long object::get<long>(interpreter &i) const
718{
719     long retVal;
720     int res = Tcl_GetLongFromObj(i.get(), obj_, &retVal);
721     if (res != TCL_OK)
722     {
723          throw tcl_error(i.get());
724     }
725
726     return retVal;
727}
728
729template <>
730char const * object::get<char const *>(interpreter &) const
731{
732     return get();
733}
734
735template <>
736string object::get<string>(interpreter &) const
737{
738     int len;
739     char const *buf = Tcl_GetStringFromObj(obj_, &len);
740     return string(buf, buf + len);
741}
742
743char const * object::get() const
744{
745     return Tcl_GetString(obj_);
746}
747
748char const * object::get(size_t &size) const
749{
750     int len;
751     unsigned char *buf = Tcl_GetByteArrayFromObj(obj_, &len);
752     size = len;
753     return const_cast<char const *>(reinterpret_cast<char *>(buf));
754}
755
756size_t object::length(interpreter &i) const
757{
758     int len;
759     int res = Tcl_ListObjLength(i.get(), obj_, &len);
760
761     if (res != TCL_OK)
762     {
763          throw tcl_error(i.get());
764     }
765
766     return static_cast<size_t>(len);
767}
768
769object object::at(interpreter &i, size_t index) const
770{
771     Tcl_Obj *o;
772     int res = Tcl_ListObjIndex(i.get(), obj_, static_cast<int>(index), &o);
773     if (res != TCL_OK)
774     {
775          throw tcl_error(i.get());
776     }
777     if (o == NULL)
778     {
779          throw tcl_error("Index out of range.");
780     }
781
782     return object(o);
783}
784
785object & object::append(interpreter &i, object const &o)
786{
787     int res = Tcl_ListObjAppendElement(i.get(), obj_, o.obj_);
788     if (res != TCL_OK)
789     {
790          throw tcl_error(i.get());
791     }
792
793     return *this;
794}
795
796object & object::append_list(interpreter &i, object const &o)
797{
798     int res = Tcl_ListObjAppendList(i.get(), obj_, o.obj_);
799     if (res != TCL_OK)
800     {
801          throw tcl_error(i.get());
802     }
803
804     return *this;
805}
806
807object & object::replace(interpreter &i, size_t index, size_t count,
808     object const &o)
809{
810     int res = Tcl_ListObjReplace(i.get(), obj_,
811          static_cast<int>(index), static_cast<int>(count),
812          1, &(o.obj_));
813     if (res != TCL_OK)
814     {
815          throw tcl_error(i.get());
816     }
817
818     return *this;
819}
820
821object & object::replace_list(interpreter &i, size_t index, size_t count,
822     object const &o)
823{
824     int objc;
825     Tcl_Obj **objv;
826
827     int res = Tcl_ListObjGetElements(i.get(), o.obj_, &objc, &objv);
828     if (res != TCL_OK)
829     {
830          throw tcl_error(i.get());
831     }
832
833     res = Tcl_ListObjReplace(i.get(), obj_,
834          static_cast<int>(index), static_cast<int>(count),
835          objc, objv);
836     if (res != TCL_OK)
837     {
838          throw tcl_error(i.get());
839     }
840
841     return *this;
842}
843
844void object::set_interp(Tcl_Interp *interp)
845{
846     interp_ = interp;
847}
848
849Tcl_Interp * object::get_interp() const
850{
851     return interp_;
852}
853
854
855interpreter::interpreter()
856{
857     interp_ =  Tcl_CreateInterp();
858     owner_ = true;
859}
860
861interpreter::interpreter(string const &libpath)
862{
863     interp_ =  Tcl_CreateInterp();
864     owner_ = true;
865
866     try
867     {
868        this->eval("set tcl_library " + libpath);
869        Tcl_Init(this->interp_);
870     } catch (...) {}
871}
872
873interpreter::interpreter(Tcl_Interp *interp, bool owner)
874{
875     interp_ =  interp;
876     owner_ = owner;
877}
878
879interpreter::~interpreter()
880{
881     if (owner_)
882     {
883          // clear all callback info belonging to this interpreter
884          clear_definitions(interp_);
885
886          Tcl_DeleteInterp(interp_);
887     }
888}
889
890void interpreter::make_safe()
891{
892     int cc = Tcl_MakeSafe(interp_);
893     if (cc != TCL_OK)
894     {
895          throw tcl_error(interp_);
896     }
897}
898
899result interpreter::eval(string const &script)
900{
901     int cc = Tcl_Eval(interp_, script.c_str());
902     if (cc != TCL_OK)
903     {
904          throw tcl_error(interp_);
905     }
906
907     return result(interp_);
908}
909
910result interpreter::eval(istream &s)
911{
912     string str(
913          istreambuf_iterator<char>(s.rdbuf()),
914          istreambuf_iterator<char>()
915     );
916     return eval(str);
917}
918
919result interpreter::eval(object const &o)
920{
921     int cc = Tcl_EvalObjEx(interp_, o.get_object(), 0);
922     if (cc != TCL_OK)
923     {
924          throw tcl_error(interp_);
925     }
926
927     return result(interp_);
928}
929
930void interpreter::pkg_provide(string const &name, string const &version)
931{
932     int cc = Tcl_PkgProvide(interp_, name.c_str(), version.c_str());
933     if (cc != TCL_OK)
934     {
935          throw tcl_error(interp_);
936     }
937}
938
939void interpreter::create_alias(string const &cmd,
940     interpreter &targetInterp, string const &targetCmd)
941{
942     int cc = Tcl_CreateAlias(interp_, cmd.c_str(),
943          targetInterp.interp_, targetCmd.c_str(), 0, 0);
944     if (cc != TCL_OK)
945     {
946          throw tcl_error(interp_);
947     }
948}
949
950void interpreter::clear_definitions(Tcl_Interp *interp)
951{
952     // delete all callbacks that were registered for given interpreter
953
954     {
955          callback_map::iterator it = callbacks.find(interp);
956          if (it == callbacks.end())
957          {
958               // no callbacks defined for this interpreter
959               return;
960          }
961
962          callback_interp_map &imap = it->second;
963          for (callback_interp_map::iterator it2 = imap.begin();
964               it2 != imap.end(); ++it2)
965          {
966               Tcl_DeleteCommand(interp, it2->first.c_str());
967          }
968
969          callbacks.erase(interp);
970     }
971
972     // delete all constructors
973
974     {
975          callback_map::iterator it = constructors.find(interp);
976          if (it == constructors.end())
977          {
978               // no callbacks defined for this interpreter
979               return;
980          }
981
982          callback_interp_map &imap = it->second;
983          for (callback_interp_map::iterator it2 = imap.begin();
984               it2 != imap.end(); ++it2)
985          {
986               Tcl_DeleteCommand(interp, it2->first.c_str());
987          }
988
989          callbacks.erase(interp);
990     }
991
992     // delete all call policies
993
994     call_policies.erase(interp);
995
996     // delete all object handlers
997     // (we have to assume that all living objects were destroyed,
998     // otherwise Bad Things will happen)
999
1000     class_handlers.erase(interp);
1001}
1002
1003void interpreter::add_function(string const &name,
1004     shared_ptr<callback_base> cb, policies const &p)
1005{
1006     Tcl_CreateObjCommand(interp_, name.c_str(),
1007          callback_handler, 0, 0);
1008
1009     callbacks[interp_][name] = cb;
1010     call_policies[interp_][name] = p;
1011}
1012
1013void interpreter::add_class(string const &name,
1014     shared_ptr<class_handler_base> chb)
1015{
1016     class_handlers[interp_][name] = chb;
1017}
1018
1019void interpreter::add_constructor(string const &name,
1020     shared_ptr<class_handler_base> chb, shared_ptr<callback_base> cb,
1021     policies const &p)
1022{
1023     Tcl_CreateObjCommand(interp_, name.c_str(),
1024          constructor_handler, static_cast<ClientData>(chb.get()), 0);
1025
1026     constructors[interp_][name] = cb;
1027     call_policies[interp_][name] = p;
1028}
1029
1030
1031int tcl_cast<int>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1032{
1033     int res;
1034     int cc = Tcl_GetIntFromObj(interp, obj, &res);
1035     if (cc != TCL_OK)
1036     {
1037          throw tcl_error(interp);
1038     }
1039
1040     return res;
1041}
1042
1043long tcl_cast<long>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1044{
1045     long res;
1046     int cc = Tcl_GetLongFromObj(interp, obj, &res);
1047     if (cc != TCL_OK)
1048     {
1049          throw tcl_error(interp);
1050     }
1051
1052     return res;
1053}
1054
1055bool tcl_cast<bool>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1056{
1057     int res;
1058     int cc = Tcl_GetBooleanFromObj(interp, obj, &res);
1059     if (cc != TCL_OK)
1060     {
1061          throw tcl_error(interp);
1062     }
1063
1064     return res != 0;
1065}
1066
1067double tcl_cast<double>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1068{
1069     double res;
1070     int cc = Tcl_GetDoubleFromObj(interp, obj, &res);
1071     if (cc != TCL_OK)
1072     {
1073          throw tcl_error(interp);
1074     }
1075
1076     return res;
1077}
1078
1079string tcl_cast<string>::from(Tcl_Interp *, Tcl_Obj *obj)
1080{
1081     return Tcl_GetString(obj);
1082}
1083
1084char const * tcl_cast<char const *>::from(Tcl_Interp *, Tcl_Obj *obj)
1085{
1086     return Tcl_GetString(obj);
1087}
1088
1089object tcl_cast<object>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1090{
1091     object o(obj);
1092     o.set_interp(interp);
1093
1094     return o;
1095}
Note: See TracBrowser for help on using the repository browser.