Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/archive/ggz2/src/external/cpptcl/cpptcl.cc @ 9937

Last change on this file since 9937 was 5738, checked in by landauf, 15 years ago

merged libraries2 back to trunk

  • Property svn:eol-style set to native
File size: 23.7 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(Tcl_Interp *interp, bool owner)
862{
863     interp_ =  interp;
864     owner_ = owner;
865}
866
867interpreter::~interpreter()
868{
869     if (owner_)
870     {
871          // clear all callback info belonging to this interpreter
872          clear_definitions(interp_);
873
874          Tcl_DeleteInterp(interp_);
875     }
876}
877
878void interpreter::make_safe()
879{
880     int cc = Tcl_MakeSafe(interp_);
881     if (cc != TCL_OK)
882     {
883          throw tcl_error(interp_);
884     }
885}
886
887result interpreter::eval(string const &script)
888{
889     int cc = Tcl_Eval(interp_, script.c_str());
890     if (cc != TCL_OK)
891     {
892          throw tcl_error(interp_);
893     }
894 
895     return result(interp_);
896}
897
898result interpreter::eval(istream &s)
899{
900     string str(
901          istreambuf_iterator<char>(s.rdbuf()),
902          istreambuf_iterator<char>()
903     );
904     return eval(str);
905}
906
907result interpreter::eval(object const &o)
908{
909     int cc = Tcl_EvalObjEx(interp_, o.get_object(), 0);
910     if (cc != TCL_OK)
911     {
912          throw tcl_error(interp_);
913     }
914 
915     return result(interp_);
916}
917
918void interpreter::pkg_provide(string const &name, string const &version)
919{
920     int cc = Tcl_PkgProvide(interp_, name.c_str(), version.c_str());
921     if (cc != TCL_OK)
922     {
923          throw tcl_error(interp_);
924     }
925}
926
927void interpreter::create_alias(string const &cmd,
928     interpreter &targetInterp, string const &targetCmd)
929{
930     int cc = Tcl_CreateAlias(interp_, cmd.c_str(),
931          targetInterp.interp_, targetCmd.c_str(), 0, 0);
932     if (cc != TCL_OK)
933     {
934          throw tcl_error(interp_);
935     }
936}
937
938void interpreter::clear_definitions(Tcl_Interp *interp)
939{
940     // delete all callbacks that were registered for given interpreter
941
942     {
943          callback_map::iterator it = callbacks.find(interp);
944          if (it == callbacks.end())
945          {
946               // no callbacks defined for this interpreter
947               return;
948          }
949
950          callback_interp_map &imap = it->second;
951          for (callback_interp_map::iterator it2 = imap.begin();
952               it2 != imap.end(); ++it2)
953          {
954               Tcl_DeleteCommand(interp, it2->first.c_str());
955          }
956
957          callbacks.erase(interp);
958     }
959
960     // delete all constructors
961
962     {
963          callback_map::iterator it = constructors.find(interp);
964          if (it == constructors.end())
965          {
966               // no callbacks defined for this interpreter
967               return;
968          }
969
970          callback_interp_map &imap = it->second;
971          for (callback_interp_map::iterator it2 = imap.begin();
972               it2 != imap.end(); ++it2)
973          {
974               Tcl_DeleteCommand(interp, it2->first.c_str());
975          }
976
977          callbacks.erase(interp);
978     }
979
980     // delete all call policies
981
982     call_policies.erase(interp);
983
984     // delete all object handlers
985     // (we have to assume that all living objects were destroyed,
986     // otherwise Bad Things will happen)
987
988     class_handlers.erase(interp);
989}
990
991void interpreter::add_function(string const &name,
992     shared_ptr<callback_base> cb, policies const &p)
993{
994     Tcl_CreateObjCommand(interp_, name.c_str(),
995          callback_handler, 0, 0);
996     
997     callbacks[interp_][name] = cb;
998     call_policies[interp_][name] = p;
999}
1000
1001void interpreter::add_class(string const &name,
1002     shared_ptr<class_handler_base> chb)
1003{
1004     class_handlers[interp_][name] = chb;
1005}
1006
1007void interpreter::add_constructor(string const &name,
1008     shared_ptr<class_handler_base> chb, shared_ptr<callback_base> cb,
1009     policies const &p)
1010{
1011     Tcl_CreateObjCommand(interp_, name.c_str(),
1012          constructor_handler, static_cast<ClientData>(chb.get()), 0);
1013
1014     constructors[interp_][name] = cb;
1015     call_policies[interp_][name] = p;
1016}
1017
1018
1019int tcl_cast<int>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1020{
1021     int res;
1022     int cc = Tcl_GetIntFromObj(interp, obj, &res);
1023     if (cc != TCL_OK)
1024     {
1025          throw tcl_error(interp);
1026     }
1027     
1028     return res;
1029}
1030
1031long tcl_cast<long>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1032{
1033     long res;
1034     int cc = Tcl_GetLongFromObj(interp, obj, &res);
1035     if (cc != TCL_OK)
1036     {
1037          throw tcl_error(interp);
1038     }
1039     
1040     return res;
1041}
1042
1043bool tcl_cast<bool>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1044{
1045     int res;
1046     int cc = Tcl_GetBooleanFromObj(interp, obj, &res);
1047     if (cc != TCL_OK)
1048     {
1049          throw tcl_error(interp);
1050     }
1051     
1052     return res != 0;
1053}
1054
1055double tcl_cast<double>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1056{
1057     double res;
1058     int cc = Tcl_GetDoubleFromObj(interp, obj, &res);
1059     if (cc != TCL_OK)
1060     {
1061          throw tcl_error(interp);
1062     }
1063     
1064     return res;
1065}
1066
1067string tcl_cast<string>::from(Tcl_Interp *, Tcl_Obj *obj)
1068{
1069     return Tcl_GetString(obj);
1070}
1071
1072char const * tcl_cast<char const *>::from(Tcl_Interp *, Tcl_Obj *obj)
1073{
1074     return Tcl_GetString(obj);
1075}
1076
1077object tcl_cast<object>::from(Tcl_Interp *interp, Tcl_Obj *obj)
1078{
1079     object o(obj);
1080     o.set_interp(interp);
1081
1082     return o;
1083}
Note: See TracBrowser for help on using the repository browser.