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