Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/branches/ggz/src/cpptcl/cpptcl.cc @ 5093

Last change on this file since 5093 was 2710, checked in by rgrieder, 16 years ago

Merged buildsystem3 containing buildsystem2 containing Adi's buildsystem branch back to the trunk.
Please update the media directory if you were not using buildsystem3 before.

  • Property svn:eol-style set to native
  • Property svn:mergeinfo set to (toggle deleted branches)
    /code/branches/buildsystem/src/cpptcl/CppTcl.cc1874-2276,​2278-2400
    /code/branches/ceguilua/src/cpptcl/CppTcl.cc1802-1808
    /code/branches/core3/src/cpptcl/CppTcl.cc1572-1739
    /code/branches/gcc43/src/cpptcl/CppTcl.cc1580
    /code/branches/gui/src/cpptcl/CppTcl.cc1635-1723
    /code/branches/input/src/cpptcl/CppTcl.cc1629-1636
    /code/branches/objecthierarchy/src/cpptcl/CppTcl.cc1911-2085,​2100,​2110-2169
    /code/branches/pickups/src/cpptcl/CppTcl.cc1926-2086
    /code/branches/questsystem/src/cpptcl/CppTcl.cc1894-2088
    /code/branches/questsystem2/src/cpptcl/CppTcl.cc2107-2259
    /code/branches/script_trigger/src/cpptcl/CppTcl.cc1295-1953,​1955
    /code/branches/weapon/src/cpptcl/CppTcl.cc1925-2094
File size: 23.9 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 (std::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 (std::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 (std::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.