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