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