OXYGENHUB
◆ main openmsx / src / commands / TclObject.cc
7.0 KiB · C++ · last changed chore(): initial commit 1 month ago source blame history raw
e8555c89 Andy McCall 1 
#include "TclObject.hh"
2
3 
#include "CommandException.hh"
4 
#include "Interpreter.hh"
5
6 
#include "narrow.hh"
7
8 
namespace openmsx {
9
10 
[[noreturn]] static void throwException(Tcl_Interp* interp)
11 
{
12 
	std::string_view message = interp ? Tcl_GetStringResult(interp)
13 
	                            : "TclObject error";
14 
	throw CommandException(message);
15 
}
16
17 
static void unshare(Tcl_Obj*& obj)
18 
{
19 
	if (Tcl_IsShared(obj)) {
20 
		Tcl_DecrRefCount(obj);
21 
		obj = Tcl_DuplicateObj(obj);
22 
		Tcl_IncrRefCount(obj);
23 
	}
24 
}
25
26 
void TclObject::addListElement(Tcl_Obj* element)
27 
{
28 
	// Although it's theoretically possible that Tcl_ListObjAppendElement()
29 
	// returns an error (e.g. adding an element to a string containing
30 
	// unbalanced quotes), this rarely occurs in our context. So we don't
31 
	// require passing an Interpreter parameter in all addListElement()
32 
	// functions. And in the very unlikely case that it does happen the
33 
	// only problem is that the error message is less descriptive than it
34 
	// could be.
35 
	unshare(obj);
36 
	Tcl_Interp* interp = nullptr;
37 
	if (Tcl_ListObjAppendElement(interp, obj, element) != TCL_OK) {
38 
		throwException(interp);
39 
	}
40 
}
41
42 
void TclObject::addListElementsImpl(std::initializer_list<Tcl_Obj*> l)
43 
{
44 
	addListElementsImpl(int(l.size()), l.begin());
45 
}
46
47 
void TclObject::addListElementsImpl(int objc, Tcl_Obj* const* objv)
48 
{
49 
	unshare(obj);
50 
	Tcl_Interp* interp = nullptr; // see comment in addListElement
51 
	if (Tcl_ListObjReplace(interp, obj, INT_MAX, 0, objc, objv) != TCL_OK) {
52 
		throwException(interp);
53 
	}
54 
}
55
56 
void TclObject::addDictKeyValues(std::initializer_list<Tcl_Obj*> keyValuePairs)
57 
{
58 
	assert((keyValuePairs.size() % 2) == 0);
59 
	unshare(obj);
60 
	Tcl_Interp* interp = nullptr; // see comment in addListElement
61 
	auto it = keyValuePairs.begin(), et = keyValuePairs.end();
62 
	while (it != et) {
63 
		Tcl_Obj* key   = *it++;
64 
		Tcl_Obj* value = *it++;
65 
		if (Tcl_DictObjPut(interp, obj, key, value) != TCL_OK) {
66 
			throwException(interp);
67 
		}
68 
	}
69 
}
70
71 
int TclObject::getInt(Interpreter& interp_) const
72 
{
73 
	auto* interp = interp_.interp;
74 
	int result;
75 
	if (Tcl_GetIntFromObj(interp, obj, &result) != TCL_OK) {
76 
		throwException(interp);
77 
	}
78 
	return result;
79 
}
80
81 
int64_t TclObject::getInt64(Interpreter& interp_) const
82 
{
83 
	auto* interp = interp_.interp;
84 
	Tcl_WideInt result;
85 
	if (Tcl_GetWideIntFromObj(interp, obj, &result) != TCL_OK) {
86 
		throwException(interp);
87 
	}
88 
	return int64_t(result);
89 
}
90
91 
std::optional<int> TclObject::getOptionalInt() const
92 
{
93 
	int result;
94 
	if (Tcl_GetIntFromObj(nullptr, obj, &result) != TCL_OK) {
95 
		return {};
96 
	}
97 
	return result;
98 
}
99
100 
std::optional<int64_t> TclObject::getOptionalInt64() const
101 
{
102 
	Tcl_WideInt result;
103 
	if (Tcl_GetWideIntFromObj(nullptr, obj, &result) != TCL_OK) {
104 
		return {};
105 
	}
106 
	return int64_t(result);
107 
}
108
109 
bool TclObject::getBoolean(Interpreter& interp_) const
110 
{
111 
	auto* interp = interp_.interp;
112 
	int result;
113 
	if (Tcl_GetBooleanFromObj(interp, obj, &result) != TCL_OK) {
114 
		throwException(interp);
115 
	}
116 
	return result != 0;
117 
}
118
119 
std::optional<bool> TclObject::getOptionalBool() const
120 
{
121 
	int result;
122 
	if (Tcl_GetBooleanFromObj(nullptr, obj, &result) != TCL_OK) {
123 
		return {};
124 
	}
125 
	return result != 0;
126 
}
127
128 
float TclObject::getFloat(Interpreter& interp_) const
129 
{
130 
	// Tcl doesn't directly support 'float', only 'double', so use that.
131 
	// But we hide this from the rest from the code, and we do the
132 
	// narrowing conversion in only this single location.
133 
	return narrow_cast<float>(getDouble(interp_));
134 
}
135 
std::optional<float> TclObject::getOptionalFloat() const
136 
{
137 
	if (auto d = getOptionalDouble()) {
138 
		return narrow_cast<float>(*d);
139 
	}
140 
	return {};
141 
}
142
143 
double TclObject::getDouble(Interpreter& interp_) const
144 
{
145 
	auto* interp = interp_.interp;
146 
	double result;
147 
	if (Tcl_GetDoubleFromObj(interp, obj, &result) != TCL_OK) {
148 
		throwException(interp);
149 
	}
150 
	return result;
151 
}
152
153 
std::optional<double> TclObject::getOptionalDouble() const
154 
{
155 
	double result;
156 
	if (Tcl_GetDoubleFromObj(nullptr, obj, &result) != TCL_OK) {
157 
		return {};
158 
	}
159 
	return result;
160 
}
161
162 
zstring_view TclObject::getString() const
163 
{
164 
	Tcl_Size length;
165 
	const char* buf = Tcl_GetStringFromObj(obj, &length);
166 
	return {buf, size_t(length)};
167 
}
168
169 
std::span<const uint8_t> TclObject::getBinary(Interpreter& interp_) const
170 
{
171 
	Tcl_Size length;
172 
#if TCL_MAJOR_VERSION >= 9
173 
	auto* interp = interp_.interp;
174 
	const auto* buf = Tcl_GetBytesFromObj(interp, obj, &length);
175 
	if (buf == nullptr) {
176 
		throwException(interp);
177 
	}
178 
#else
179 
	(void)interp_;
180 
	const auto* buf = Tcl_GetByteArrayFromObj(obj, &length);
181 
#endif
182 
	return {buf, size_t(length)};
183 
}
184
185 
size_t TclObject::getListLength(Interpreter& interp_) const
186 
{
187 
	auto* interp = interp_.interp;
188 
	Tcl_Size result;
189 
	if (Tcl_ListObjLength(interp, obj, &result) != TCL_OK) {
190 
		throwException(interp);
191 
	}
192 
	return result;
193 
}
194 
size_t TclObject::getListLengthUnchecked() const
195 
{
196 
	Tcl_Size result;
197 
	if (Tcl_ListObjLength(nullptr, obj, &result) != TCL_OK) {
198 
		return 0; // error
199 
	}
200 
	return result;
201 
}
202
203 
TclObject TclObject::getListIndex(Interpreter& interp_, size_t index) const
204 
{
205 
	auto* interp = interp_.interp;
206 
	Tcl_Obj* element;
207 
	if (Tcl_ListObjIndex(interp, obj, narrow<int>(index), &element) != TCL_OK) {
208 
		throwException(interp);
209 
	}
210 
	return element ? TclObject(element) : TclObject();
211 
}
212 
TclObject TclObject::getListIndexUnchecked(size_t index) const
213 
{
214 
	Tcl_Obj* element;
215 
	if (Tcl_ListObjIndex(nullptr, obj, narrow<int>(index), &element) != TCL_OK) {
216 
		return {};
217 
	}
218 
	return element ? TclObject(element) : TclObject();
219 
}
220
221 
void TclObject::removeListIndex(Interpreter& interp_, size_t index)
222 
{
223 
	unshare(obj);
224 
	auto* interp = interp_.interp;
225 
	if (Tcl_ListObjReplace(interp, obj, narrow<int>(index), 1, 0, nullptr) != TCL_OK) {
226 
		throwException(interp);
227 
	}
228 
}
229
230 
void TclObject::setDictValue(Interpreter& interp_, const TclObject& key, const TclObject& value)
231 
{
232 
	unshare(obj);
233 
	auto* interp = interp_.interp;
234 
	if (Tcl_DictObjPut(interp, obj, key.obj, value.obj) != TCL_OK) {
235 
		throwException(interp);
236 
	}
237 
}
238
239 
TclObject TclObject::getDictValue(Interpreter& interp_, const TclObject& key) const
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 
std::optional<TclObject> TclObject::getOptionalDictValue(const TclObject& key) const
250 
{
251 
	Tcl_Obj* value;
252 
	if ((Tcl_DictObjGet(nullptr, obj, key.obj, &value) != TCL_OK) || !value) {
253 
		return {};
254 
	}
255 
	return TclObject(value);
256 
}
257
258 
bool TclObject::evalBool(Interpreter& interp_) const
259 
{
260 
	auto* interp = interp_.interp;
261 
	int result;
262 
	if (Tcl_ExprBooleanObj(interp, obj, &result) != TCL_OK) {
263 
		throwException(interp);
264 
	}
265 
	return result != 0;
266 
}
267
268 
TclObject TclObject::eval(Interpreter& interp_) const
269 
{
270 
	auto* interp = interp_.interp;
271 
	Tcl_Obj* result;
272 
	if (Tcl_ExprObj(interp, obj, &result) != TCL_OK) {
273 
		throwException(interp);
274 
	}
275 
	return TclObject(result);
276 
}
277
278 
TclObject TclObject::executeCommand(Interpreter& interp_, bool compile)
279 
{
280 
	auto* interp = interp_.interp;
281 
	if (int flags = compile ? 0 : TCL_EVAL_DIRECT;
282 
	    Tcl_EvalObjEx(interp, obj, flags) != TCL_OK) {
283 
		throw CommandException(Tcl_GetStringResult(interp));
284 
	}
285 
	return TclObject(Tcl_GetObjResult(interp));
286 
}
287
288 
} // namespace openmsx