openMSX
TclObject.cc
Go to the documentation of this file.
1 #include "TclObject.hh"
2 #include "Interpreter.hh"
3 #include "CommandException.hh"
4 #include <tcl.h>
5 
6 namespace openmsx {
7 
9 {
10  init(Tcl_NewObj());
11 }
12 
13 TclObject::TclObject(Tcl_Obj* obj_)
14 {
15  init(obj_);
16 }
17 
19 {
20  init(Tcl_NewStringObj(value.data(), int(value.size())));
21 }
22 
24 {
25  init(Tcl_NewIntObj(value));
26 }
27 
28 TclObject::TclObject(double value)
29 {
30  init(Tcl_NewDoubleObj(value));
31 }
32 
34 {
35  init(object.obj);
36 }
37 
38 void TclObject::init(Tcl_Obj* obj_)
39 {
40  obj = obj_;
41  Tcl_IncrRefCount(obj);
42 }
43 
45 {
46  Tcl_DecrRefCount(obj);
47 }
48 
50 {
51  if (&other != this) {
52  Tcl_DecrRefCount(obj);
53  init(other.obj);
54  }
55  return *this;
56 }
57 
58 static void throwException(Tcl_Interp* interp)
59 {
60  string_ref message = interp ? Tcl_GetStringResult(interp)
61  : "TclObject error";
62  throw CommandException(message);
63 }
64 
66 {
67  if (Tcl_IsShared(obj)) {
68  Tcl_DecrRefCount(obj);
69  obj = Tcl_NewStringObj(value.data(), int(value.size()));
70  Tcl_IncrRefCount(obj);
71  } else {
72  Tcl_SetStringObj(obj, value.data(), int(value.size()));
73  }
74 }
75 
76 void TclObject::setInt(int value)
77 {
78  if (Tcl_IsShared(obj)) {
79  Tcl_DecrRefCount(obj);
80  obj = Tcl_NewIntObj(value);
81  Tcl_IncrRefCount(obj);
82  } else {
83  Tcl_SetIntObj(obj, value);
84  }
85 }
86 
87 void TclObject::setBoolean(bool value)
88 {
89  if (Tcl_IsShared(obj)) {
90  Tcl_DecrRefCount(obj);
91  obj = Tcl_NewBooleanObj(value);
92  Tcl_IncrRefCount(obj);
93  } else {
94  Tcl_SetBooleanObj(obj, value);
95  }
96 }
97 
98 void TclObject::setDouble(double value)
99 {
100  if (Tcl_IsShared(obj)) {
101  Tcl_DecrRefCount(obj);
102  obj = Tcl_NewDoubleObj(value);
103  Tcl_IncrRefCount(obj);
104  } else {
105  Tcl_SetDoubleObj(obj, value);
106  }
107 }
108 
109 void TclObject::setBinary(byte* buf, unsigned length)
110 {
111  if (Tcl_IsShared(obj)) {
112  Tcl_DecrRefCount(obj);
113  obj = Tcl_NewByteArrayObj(buf, length);
114  Tcl_IncrRefCount(obj);
115  } else {
116  Tcl_SetByteArrayObj(obj, buf, length);
117  }
118 }
119 
121 {
122  addListElement(Tcl_NewStringObj(element.data(), int(element.size())));
123 }
124 
126 {
127  addListElement(Tcl_NewIntObj(value));
128 }
129 
130 void TclObject::addListElement(double value)
131 {
132  addListElement(Tcl_NewDoubleObj(value));
133 }
134 
136 {
137  addListElement(element.obj);
138 }
139 
140 void TclObject::addListElement(Tcl_Obj* element)
141 {
142  // Although it's theoretically possible that Tcl_ListObjAppendElement()
143  // returns an error (e.g. adding an element to a string containing
144  // unbalanced quotes), this rarely occurs in our context. So we don't
145  // require passing an Interpreter parameter in all addListElement()
146  // functions. And in the very unlikely case that it does happen the
147  // only problem is that the error message is less descriptive than it
148  // could be.
149  Tcl_Interp* interp = nullptr;
150  if (Tcl_IsShared(obj)) {
151  Tcl_DecrRefCount(obj);
152  obj = Tcl_DuplicateObj(obj);
153  Tcl_IncrRefCount(obj);
154  }
155  if (Tcl_ListObjAppendElement(interp, obj, element) != TCL_OK) {
156  throwException(interp);
157  }
158 }
159 
160 int TclObject::getInt(Interpreter& interp_) const
161 {
162  auto* interp = interp_.interp;
163  int result;
164  if (Tcl_GetIntFromObj(interp, obj, &result) != TCL_OK) {
165  throwException(interp);
166  }
167  return result;
168 }
169 
170 bool TclObject::getBoolean(Interpreter& interp_) const
171 {
172  auto* interp = interp_.interp;
173  int result;
174  if (Tcl_GetBooleanFromObj(interp, obj, &result) != TCL_OK) {
175  throwException(interp);
176  }
177  return result != 0;
178 }
179 
180 double TclObject::getDouble(Interpreter& interp_) const
181 {
182  auto* interp = interp_.interp;
183  double result;
184  if (Tcl_GetDoubleFromObj(interp, obj, &result) != TCL_OK) {
185  throwException(interp);
186  }
187  return result;
188 }
189 
191 {
192  int length;
193  char* buf = Tcl_GetStringFromObj(obj, &length);
194  return string_ref(buf, length);
195 }
196 
197 const byte* TclObject::getBinary(unsigned& length) const
198 {
199  return static_cast<const byte*>(Tcl_GetByteArrayFromObj(
200  obj, reinterpret_cast<int*>(&length)));
201 }
202 
203 unsigned TclObject::getListLength(Interpreter& interp_) const
204 {
205  auto* interp = interp_.interp;
206  int result;
207  if (Tcl_ListObjLength(interp, obj, &result) != TCL_OK) {
208  throwException(interp);
209  }
210  return result;
211 }
212 unsigned TclObject::getListLengthUnchecked() const
213 {
214  int result;
215  if (Tcl_ListObjLength(nullptr, obj, &result) != TCL_OK) {
216  return 0; // error
217  }
218  return result;
219 }
220 
221 TclObject TclObject::getListIndex(Interpreter& interp_, unsigned index) const
222 {
223  auto* interp = interp_.interp;
224  Tcl_Obj* element;
225  if (Tcl_ListObjIndex(interp, obj, index, &element) != TCL_OK) {
226  throwException(interp);
227  }
228  return element ? TclObject(element) : TclObject();
229 }
230 TclObject TclObject::getListIndexUnchecked(unsigned index) const
231 {
232  Tcl_Obj* element;
233  if (Tcl_ListObjIndex(nullptr, obj, index, &element) != TCL_OK) {
234  return TclObject();
235  }
236  return element ? TclObject(element) : TclObject();
237 }
238 
240 {
241  auto* interp = interp_.interp;
242  Tcl_Obj* value;
243  if (Tcl_DictObjGet(interp, obj, key.obj, &value) != TCL_OK) {
244  throwException(interp);
245  }
246  return value ? TclObject(value) : TclObject();
247 }
248 
249 bool TclObject::evalBool(Interpreter& interp_) const
250 {
251  auto* interp = interp_.interp;
252  int result;
253  if (Tcl_ExprBooleanObj(interp, obj, &result) != TCL_OK) {
254  throwException(interp);
255  }
256  return result != 0;
257 }
258 
260 {
261  auto* interp = interp_.interp;
262  int flags = compile ? 0 : TCL_EVAL_DIRECT;
263  int success = Tcl_EvalObjEx(interp, obj, flags);
264  if (success != TCL_OK) {
265  throw CommandException(Tcl_GetStringResult(interp));
266  }
267  return TclObject(Tcl_GetObjResult(interp));
268 }
269 
270 } // namespace openmsx
void setBinary(byte *buf, unsigned length)
Definition: TclObject.cc:109
void setDouble(double value)
Definition: TclObject.cc:98
T length(const vecN< N, T > &x)
Definition: gl_vec.hh:281
int getInt(Interpreter &interp) const
Definition: TclObject.cc:160
bool getBoolean(Interpreter &interp) const
Definition: TclObject.cc:170
string_ref getString() const
Definition: TclObject.cc:190
bool evalBool(Interpreter &interp) const
Definition: TclObject.cc:249
unsigned char byte
8 bit unsigned integer
Definition: openmsx.hh:27
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:197
void setBoolean(bool value)
Definition: TclObject.cc:87
size_type size() const
Definition: string_ref.hh:55
const char * data() const
Definition: string_ref.hh:68
TclObject getDictValue(Interpreter &interp, const TclObject &key) const
Definition: TclObject.cc:239
TclObject getListIndex(Interpreter &interp, unsigned index) const
Definition: TclObject.cc:221
unsigned getListLength(Interpreter &interp) const
Definition: TclObject.cc:203
TclObject & operator=(const TclObject &other)
Definition: TclObject.cc:49
Thanks to enen for testing this on a real cartridge:
Definition: Autofire.cc:7
void addListElement(string_ref element)
Definition: TclObject.cc:120
void setString(string_ref value)
Definition: TclObject.cc:65
void setInt(int value)
Definition: TclObject.cc:76
TclObject executeCommand(Interpreter &interp, bool compile=false)
Interpret this TclObject as a command and execute it.
Definition: TclObject.cc:259
double getDouble(Interpreter &interp) const
Definition: TclObject.cc:180