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