openMSX
TclObject.cc
Go to the documentation of this file.
1 #include "TclObject.hh"
2 #include "Interpreter.hh"
3 #include "CommandException.hh"
4 #include <cassert>
5 #include <tcl.h>
6 
7 using std::string;
8 
9 namespace openmsx {
10 
11 // class TclObject
12 
13 TclObject::TclObject(Tcl_Interp* interp_, Tcl_Obj* obj_)
14  : interp(interp_)
15 {
16  init(obj_);
17 }
18 
19 TclObject::TclObject(Tcl_Interp* interp_, string_ref value)
20  : interp(interp_)
21 {
22  init(Tcl_NewStringObj(value.data(), int(value.size())));
23 }
24 
26  : interp(interp_.interp)
27 {
28  init(Tcl_NewStringObj(value.data(), int(value.size())));
29 }
30 
32  : interp(nullptr)
33 {
34  init(Tcl_NewStringObj(value.data(), int(value.size())));
35 }
36 
37 TclObject::TclObject(Tcl_Interp* interp_)
38  : interp(interp_)
39 {
40  init(Tcl_NewObj());
41 }
42 
44  : interp(interp_.interp)
45 {
46  init(Tcl_NewObj());
47 }
48 
50  : interp(object.interp)
51 {
52  init(object.obj);
53 }
54 
56  : interp(nullptr)
57 {
58  init(Tcl_NewObj());
59 }
60 
61 void TclObject::init(Tcl_Obj* obj_)
62 {
63  obj = obj_;
64  Tcl_IncrRefCount(obj);
65 }
66 
68 {
69  Tcl_DecrRefCount(obj);
70 }
71 
73 {
74  if (&other != this) {
75  Tcl_DecrRefCount(obj);
76  interp = other.interp;
77  init(other.obj);
78  }
79  return *this;
80 }
81 
82 Tcl_Interp* TclObject::getInterpreter() const
83 {
84  return interp;
85 }
86 
88 {
89  return obj;
90 }
91 
92 void TclObject::throwException() const
93 {
94  string_ref message = interp ? Tcl_GetStringResult(interp)
95  : "TclObject error";
96  throw CommandException(message);
97 }
98 
100 {
101  if (Tcl_IsShared(obj)) {
102  Tcl_DecrRefCount(obj);
103  obj = Tcl_NewStringObj(value.data(), int(value.size()));
104  Tcl_IncrRefCount(obj);
105  } else {
106  Tcl_SetStringObj(obj, value.data(), int(value.size()));
107  }
108 }
109 
110 void TclObject::setInt(int value)
111 {
112  if (Tcl_IsShared(obj)) {
113  Tcl_DecrRefCount(obj);
114  obj = Tcl_NewIntObj(value);
115  Tcl_IncrRefCount(obj);
116  } else {
117  Tcl_SetIntObj(obj, value);
118  }
119 }
120 
121 void TclObject::setBoolean(bool value)
122 {
123  if (Tcl_IsShared(obj)) {
124  Tcl_DecrRefCount(obj);
125  obj = Tcl_NewBooleanObj(value);
126  Tcl_IncrRefCount(obj);
127  } else {
128  Tcl_SetBooleanObj(obj, value);
129  }
130 }
131 
132 void TclObject::setDouble(double value)
133 {
134  if (Tcl_IsShared(obj)) {
135  Tcl_DecrRefCount(obj);
136  obj = Tcl_NewDoubleObj(value);
137  Tcl_IncrRefCount(obj);
138  } else {
139  Tcl_SetDoubleObj(obj, value);
140  }
141 }
142 
143 void TclObject::setBinary(byte* buf, unsigned length)
144 {
145  if (Tcl_IsShared(obj)) {
146  Tcl_DecrRefCount(obj);
147  obj = Tcl_NewByteArrayObj(buf, length);
148  Tcl_IncrRefCount(obj);
149  } else {
150  Tcl_SetByteArrayObj(obj, buf, length);
151  }
152 }
153 
155 {
156  addListElement(Tcl_NewStringObj(element.data(), int(element.size())));
157 }
158 
160 {
161  addListElement(Tcl_NewIntObj(value));
162 }
163 
164 void TclObject::addListElement(double value)
165 {
166  addListElement(Tcl_NewDoubleObj(value));
167 }
168 
170 {
171  addListElement(element.obj);
172 }
173 
174 void TclObject::addListElement(Tcl_Obj* element)
175 {
176  if (Tcl_IsShared(obj)) {
177  Tcl_DecrRefCount(obj);
178  obj = Tcl_DuplicateObj(obj);
179  Tcl_IncrRefCount(obj);
180  }
181  if (Tcl_ListObjAppendElement(interp, obj, element) != TCL_OK) {
182  throwException();
183  }
184 }
185 
186 int TclObject::getInt() const
187 {
188  int result;
189  if (Tcl_GetIntFromObj(interp, obj, &result) != TCL_OK) {
190  throwException();
191  }
192  return result;
193 }
194 
196 {
197  int result;
198  if (Tcl_GetBooleanFromObj(interp, obj, &result) != TCL_OK) {
199  throwException();
200  }
201  return result != 0;
202 }
203 
204 double TclObject::getDouble() const
205 {
206  double result;
207  if (Tcl_GetDoubleFromObj(interp, obj, &result) != TCL_OK) {
208  throwException();
209  }
210  return result;
211 }
212 
214 {
215  int length;
216  char* buf = Tcl_GetStringFromObj(obj, &length);
217  return string_ref(buf, length);
218 }
219 
220 const byte* TclObject::getBinary(unsigned& length) const
221 {
222  return static_cast<const byte*>(Tcl_GetByteArrayFromObj(
223  obj, reinterpret_cast<int*>(&length)));
224 }
225 
226 unsigned TclObject::getListLength() const
227 {
228  int result;
229  if (Tcl_ListObjLength(interp, obj, &result) != TCL_OK) {
230  throwException();
231  }
232  return result;
233 }
234 
235 TclObject TclObject::getListIndex(unsigned index) const
236 {
237  Tcl_Obj* element;
238  if (Tcl_ListObjIndex(interp, obj, index, &element) != TCL_OK) {
239  throwException();
240  }
241  return element ? TclObject(interp, element)
242  : TclObject(interp);
243 }
244 
246 {
247  Tcl_Obj* value;
248  if (Tcl_DictObjGet(interp, obj, key.obj, &value) != TCL_OK) {
249  throwException();
250  }
251  return value ? TclObject(interp, value)
252  : TclObject(interp);
253 }
254 
256 {
257  int result;
258  if (Tcl_ExprBooleanObj(interp, obj, &result) != TCL_OK) {
259  throwException();
260  }
261  return result != 0;
262 }
263 
264 string TclObject::executeCommand(bool compile)
265 {
266  assert(interp);
267  int flags = compile ? 0 : TCL_EVAL_DIRECT;
268  int success = Tcl_EvalObjEx(interp, obj, flags);
269  string result = Tcl_GetStringResult(interp);
270  if (success != TCL_OK) {
271  throw CommandException(result);
272  }
273  return result;
274 }
275 
276 } // namespace openmsx
void setBinary(byte *buf, unsigned length)
Definition: TclObject.cc:143
void setDouble(double value)
Definition: TclObject.cc:132
unsigned getListLength() const
Definition: TclObject.cc:226
string_ref getString() const
Definition: TclObject.cc:213
unsigned char byte
8 bit unsigned integer
Definition: openmsx.hh:33
Tcl_Obj * getTclObject()
Definition: TclObject.cc:87
std::string executeCommand(bool compile=false)
Interpret this TclObject as a command and execute it.
Definition: TclObject.cc:264
This class implements a subset of the proposal for std::string_ref (proposed for the next c++ standar...
Definition: string_ref.hh:18
const byte * getBinary(unsigned &length) const
Definition: TclObject.cc:220
void setBoolean(bool value)
Definition: TclObject.cc:121
bool getBoolean() const
Definition: TclObject.cc:195
size_type size() const
Definition: string_ref.hh:55
Tcl_Interp * getInterpreter() const
Definition: TclObject.cc:82
const char * data() const
Definition: string_ref.hh:68
bool evalBool() const
Definition: TclObject.cc:255
TclObject & operator=(const TclObject &other)
Definition: TclObject.cc:72
TclObject getListIndex(unsigned index) const
Definition: TclObject.cc:235
TclObject getDictValue(const TclObject &key) const
Definition: TclObject.cc:245
void addListElement(string_ref element)
Definition: TclObject.cc:154
void setString(string_ref value)
Definition: TclObject.cc:99
int getInt() const
Definition: TclObject.cc:186
void setInt(int value)
Definition: TclObject.cc:110
double getDouble() const
Definition: TclObject.cc:204