Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/branches/HUD_HS16/src/external/cpptcl/cpptcl.cc @ 11574

Last change on this file since 11574 was 11071, checked in by landauf, 9 years ago

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