openMSX
TclObject.cc
Go to the documentation of this file.
1#include "TclObject.hh"
2#include "Interpreter.hh"
3#include "CommandException.hh"
4#include "narrow.hh"
5
6namespace openmsx {
7
8static void throwException(Tcl_Interp* interp)
9{
10 std::string_view message = interp ? Tcl_GetStringResult(interp)
11 : "TclObject error";
12 throw CommandException(message);
13}
14
15static void unshare(Tcl_Obj*& obj)
16{
17 if (Tcl_IsShared(obj)) {
18 Tcl_DecrRefCount(obj);
19 obj = Tcl_DuplicateObj(obj);
20 Tcl_IncrRefCount(obj);
21 }
22}
23
24void TclObject::addListElement(Tcl_Obj* element)
25{
26 // Although it's theoretically possible that Tcl_ListObjAppendElement()
27 // returns an error (e.g. adding an element to a string containing
28 // unbalanced quotes), this rarely occurs in our context. So we don't
29 // require passing an Interpreter parameter in all addListElement()
30 // functions. And in the very unlikely case that it does happen the
31 // only problem is that the error message is less descriptive than it
32 // could be.
33 unshare(obj);
34 Tcl_Interp* interp = nullptr;
35 if (Tcl_ListObjAppendElement(interp, obj, element) != TCL_OK) {
36 throwException(interp);
37 }
38}
39
40void TclObject::addListElementsImpl(std::initializer_list<Tcl_Obj*> l)
41{
42 Tcl_Obj* const* objv = l.begin();
43 addListElementsImpl(int(l.size()), objv);
44}
45
46void TclObject::addListElementsImpl(int objc, Tcl_Obj* const* objv)
47{
48 unshare(obj);
49 Tcl_Interp* interp = nullptr; // see comment in addListElement
50 if (Tcl_ListObjReplace(interp, obj, INT_MAX, 0, objc, objv) != TCL_OK) {
51 throwException(interp);
52 }
53}
54
55void TclObject::addDictKeyValues(std::initializer_list<Tcl_Obj*> keyValuePairs)
56{
57 assert((keyValuePairs.size() % 2) == 0);
58 unshare(obj);
59 Tcl_Interp* interp = nullptr; // see comment in addListElement
60 auto it = keyValuePairs.begin(), et = keyValuePairs.end();
61 while (it != et) {
62 Tcl_Obj* key = *it++;
63 Tcl_Obj* value = *it++;
64 if (Tcl_DictObjPut(interp, obj, key, value) != TCL_OK) {
65 throwException(interp);
66 }
67 }
68}
69
70int TclObject::getInt(Interpreter& interp_) const
71{
72 auto* interp = interp_.interp;
73 int result;
74 if (Tcl_GetIntFromObj(interp, obj, &result) != TCL_OK) {
75 throwException(interp);
76 }
77 return result;
78}
79
80std::optional<int> TclObject::getOptionalInt() const
81{
82 int result;
83 if (Tcl_GetIntFromObj(nullptr, obj, &result) != TCL_OK) {
84 return {};
85 }
86 return result;
87}
88
90{
91 auto* interp = interp_.interp;
92 int result;
93 if (Tcl_GetBooleanFromObj(interp, obj, &result) != TCL_OK) {
94 throwException(interp);
95 }
96 return result != 0;
97}
98
99std::optional<bool> TclObject::getOptionalBool() const
100{
101 int result;
102 if (Tcl_GetBooleanFromObj(nullptr, obj, &result) != TCL_OK) {
103 return {};
104 }
105 return result != 0;
106}
107
108float TclObject::getFloat(Interpreter& interp_) const
109{
110 // Tcl doesn't directly support 'float', only 'double', so use that.
111 // But we hide this from the rest from the code, and we do the
112 // narrowing conversion in only this single location.
113 return narrow_cast<float>(getDouble(interp_));
114}
115std::optional<float> TclObject::getOptionalFloat() const
116{
117 if (auto d = getOptionalDouble()) {
118 return narrow_cast<float>(*d);
119 }
120 return {};
121}
122
123double TclObject::getDouble(Interpreter& interp_) const
124{
125 auto* interp = interp_.interp;
126 double result;
127 if (Tcl_GetDoubleFromObj(interp, obj, &result) != TCL_OK) {
128 throwException(interp);
129 }
130 return result;
131}
132
133std::optional<double> TclObject::getOptionalDouble() const
134{
135 double result;
136 if (Tcl_GetDoubleFromObj(nullptr, obj, &result) != TCL_OK) {
137 return {};
138 }
139 return result;
140}
141
143{
144 int length;
145 char* buf = Tcl_GetStringFromObj(obj, &length);
146 return {buf, size_t(length)};
147}
148
149std::span<const uint8_t> TclObject::getBinary() const
150{
151 int length;
152 auto* buf = Tcl_GetByteArrayFromObj(obj, &length);
153 return {buf, size_t(length)};
154}
155
156unsigned TclObject::getListLength(Interpreter& interp_) const
157{
158 auto* interp = interp_.interp;
159 int result;
160 if (Tcl_ListObjLength(interp, obj, &result) != TCL_OK) {
161 throwException(interp);
162 }
163 return result;
164}
165unsigned TclObject::getListLengthUnchecked() const
166{
167 int result;
168 if (Tcl_ListObjLength(nullptr, obj, &result) != TCL_OK) {
169 return 0; // error
170 }
171 return result;
172}
173
174TclObject TclObject::getListIndex(Interpreter& interp_, unsigned index) const
175{
176 auto* interp = interp_.interp;
177 Tcl_Obj* element;
178 if (Tcl_ListObjIndex(interp, obj, narrow<int>(index), &element) != TCL_OK) {
179 throwException(interp);
180 }
181 return element ? TclObject(element) : TclObject();
182}
184{
185 Tcl_Obj* element;
186 if (Tcl_ListObjIndex(nullptr, obj, narrow<int>(index), &element) != TCL_OK) {
187 return {};
188 }
189 return element ? TclObject(element) : TclObject();
190}
191
192void TclObject::removeListIndex(Interpreter& interp_, unsigned index)
193{
194 unshare(obj);
195 auto* interp = interp_.interp;
196 if (Tcl_ListObjReplace(interp, obj, narrow<int>(index), 1, 0, nullptr) != TCL_OK) {
197 throwException(interp);
198 }
199}
200
201void TclObject::setDictValue(Interpreter& interp_, const TclObject& key, const TclObject& value)
202{
203 unshare(obj);
204 auto* interp = interp_.interp;
205 if (Tcl_DictObjPut(interp, obj, key.obj, value.obj) != TCL_OK) {
206 throwException(interp);
207 }
208}
209
211{
212 auto* interp = interp_.interp;
213 Tcl_Obj* value;
214 if (Tcl_DictObjGet(interp, obj, key.obj, &value) != TCL_OK) {
215 throwException(interp);
216 }
217 return value ? TclObject(value) : TclObject();
218}
219
220std::optional<TclObject> TclObject::getOptionalDictValue(const TclObject& key) const
221{
222 Tcl_Obj* value;
223 if ((Tcl_DictObjGet(nullptr, obj, key.obj, &value) != TCL_OK) || !value) {
224 return {};
225 }
226 return TclObject(value);
227}
228
230{
231 auto* interp = interp_.interp;
232 int result;
233 if (Tcl_ExprBooleanObj(interp, obj, &result) != TCL_OK) {
234 throwException(interp);
235 }
236 return result != 0;
237}
238
240{
241 auto* interp = interp_.interp;
242 Tcl_Obj* result;
243 if (Tcl_ExprObj(interp, obj, &result) != TCL_OK) {
244 throwException(interp);
245 }
246 return TclObject(result);
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
bool getBoolean(Interpreter &interp) const
Definition TclObject.cc:89
TclObject executeCommand(Interpreter &interp, bool compile=false)
Interpret this TclObject as a command and execute it.
Definition TclObject.cc:249
unsigned getListLength(Interpreter &interp) const
Definition TclObject.cc:156
TclObject getListIndexUnchecked(unsigned index) const
Definition TclObject.cc:183
TclObject getListIndex(Interpreter &interp, unsigned index) const
Definition TclObject.cc:174
bool evalBool(Interpreter &interp) const
Definition TclObject.cc:229
std::optional< TclObject > getOptionalDictValue(const TclObject &key) const
Definition TclObject.cc:220
void removeListIndex(Interpreter &interp, unsigned index)
Definition TclObject.cc:192
double getDouble(Interpreter &interp) const
Definition TclObject.cc:123
float getFloat(Interpreter &interp) const
Definition TclObject.cc:108
TclObject eval(Interpreter &interp) const
Definition TclObject.cc:239
void addListElement(const T &t)
Definition TclObject.hh:127
std::span< const uint8_t > getBinary() const
Definition TclObject.cc:149
std::optional< float > getOptionalFloat() const
Definition TclObject.cc:115
int getInt(Interpreter &interp) const
Definition TclObject.cc:70
void addDictKeyValues(Args &&... args)
Definition TclObject.hh:144
std::optional< bool > getOptionalBool() const
Definition TclObject.cc:99
TclObject getDictValue(Interpreter &interp, const TclObject &key) const
Definition TclObject.cc:210
std::optional< int > getOptionalInt() const
Definition TclObject.cc:80
zstring_view getString() const
Definition TclObject.cc:142
std::optional< double > getOptionalDouble() const
Definition TclObject.cc:133
void setDictValue(Interpreter &interp, const TclObject &key, const TclObject &value)
Definition TclObject.cc:201
Like std::string_view, but with the extra guarantee that it refers to a zero-terminated string.
This file implemented 3 utility functions:
Definition Autofire.cc:9