openMSX
Interpreter.cc
Go to the documentation of this file.
1#include "Interpreter.hh"
2#include "Command.hh"
3#include "TclObject.hh"
4#include "CommandException.hh"
6#include "MSXMotherBoard.hh"
7#include "Setting.hh"
9#include "MSXCPUInterface.hh"
10#include "FileOperations.hh"
11#include "ranges.hh"
12#include "stl.hh"
13#include "unreachable.hh"
14#include <iostream>
15#include <span>
16#include <utility>
17#include <vector>
18#include <cstdint>
19//#include <tk.h>
20
21namespace openmsx {
22
23// See comments in traceProc()
24namespace {
25 struct Trace {
26 uintptr_t id;
27 BaseSetting* setting;
28 };
29}
30static std::vector<Trace> traces; // sorted on id
31static uintptr_t traceCount = 0;
32
33
34static int dummyClose(ClientData /*instanceData*/, Tcl_Interp* /*interp*/)
35{
36 return 0;
37}
38static int dummyInput(ClientData /*instanceData*/, char* /*buf*/,
39 int /*bufSize*/, int* /*errorCodePtr*/)
40{
41 return 0;
42}
43static void dummyWatch(ClientData /*instanceData*/, int /*mask*/)
44{
45}
46static int dummyGetHandle(ClientData /*instanceData*/, int /*direction*/,
47 ClientData* /*handlePtr*/)
48{
49 return TCL_ERROR;
50}
51Tcl_ChannelType Interpreter::channelType = {
52 const_cast<char*>("openMSX console"),// Type name
53 nullptr, // Always non-blocking
54 dummyClose, // Close proc
55 dummyInput, // Input proc
56 Interpreter::outputProc, // Output proc
57 nullptr, // Seek proc
58 nullptr, // Set option proc
59 nullptr, // Get option proc
60 dummyWatch, // Watch for events on console
61 dummyGetHandle, // Get a handle from the device
62 nullptr, // Tcl_DriverClose2Proc
63 nullptr, // Tcl_DriverBlockModeProc
64 nullptr, // Tcl_DriverFlushProc
65 nullptr, // Tcl_DriverHandlerProc
66 nullptr, // Tcl_DriverWideSeekProc
67 nullptr, // Tcl_DriverThreadActionProc
68 nullptr, // Tcl_DriverTruncateProc
69};
70
71void Interpreter::init(const char* programName)
72{
73 Tcl_FindExecutable(programName);
74}
75
77 : interp(Tcl_CreateInterp())
78{
79 Tcl_Preserve(interp);
80
81 // TODO need to investigate this: doesn't work on windows
82 /*
83 if (Tcl_Init(interp) != TCL_OK) {
84 std::cout << "Tcl_Init: " << interp->result << '\n';
85 }
86 if (Tk_Init(interp) != TCL_OK) {
87 std::cout << "Tk_Init error: " << interp->result << '\n';
88 }
89 if (Tcl_Eval(interp, "wm withdraw .") != TCL_OK) {
90 std::cout << "wm withdraw error: " << interp->result << '\n';
91 }
92 */
93
94 Tcl_Channel channel = Tcl_CreateChannel(&channelType,
95 "openMSX console", this, TCL_WRITABLE);
96 if (channel) {
97 Tcl_SetChannelOption(interp, channel, "-translation", "binary");
98 Tcl_SetChannelOption(interp, channel, "-buffering", "line");
99 Tcl_SetChannelOption(interp, channel, "-encoding", "utf-8");
100 }
101 Tcl_SetStdChannel(channel, TCL_STDOUT);
102
103 setVariable(TclObject("env(OPENMSX_USER_DATA)"),
105 setVariable(TclObject("env(OPENMSX_SYSTEM_DATA)"),
107}
108
110{
111 // see comment in MSXCPUInterface::cleanup()
113
114 if (!Tcl_InterpDeleted(interp)) {
115 Tcl_DeleteInterp(interp);
116 }
117 Tcl_Release(interp);
118
119 // Tcl_Finalize() should only be called once for the whole application
120 // tcl8.6 checks for this (tcl8.5 did not).
121 // Normally we only create/destroy exactly one Interpreter object for
122 // openMSX, and then simply calling Tcl_Finalize() here is fine. Though
123 // when running unittest we do create/destroy multiple Interpreter's.
124 // Another option is to not call Tcl_Finalize(), but that leaves some
125 // memory allocated, and makes memory-leak checkers report more errors.
126 static bool scheduled = false;
127 if (!scheduled) {
128 scheduled = true;
129 atexit(Tcl_Finalize);
130 }
131}
132
133int Interpreter::outputProc(ClientData clientData, const char* buf,
134 int toWrite, int* /*errorCodePtr*/)
135{
136 try {
137 auto* output = static_cast<Interpreter*>(clientData)->output;
138 std::string_view text(buf, toWrite);
139 if (!text.empty() && output) {
140 output->output(text);
141 }
142 } catch (...) {
143 UNREACHABLE; // we cannot let exceptions pass through Tcl
144 }
145 return toWrite;
146}
147
149{
150 // Note: these are not only the commands registered via
151 // registerCommand(), but all commands know to this Tcl-interpreter.
152 return Tcl_FindCommand(interp, name.c_str(), nullptr, 0);
153}
154
156{
157 auto token = Tcl_CreateObjCommand(
158 interp, name.c_str(), commandProc,
159 static_cast<ClientData>(&command), nullptr);
160 command.setToken(token);
161}
162
164{
165 Tcl_DeleteCommandFromToken(interp, static_cast<Tcl_Command>(command.getToken()));
166}
167
168int Interpreter::commandProc(ClientData clientData, Tcl_Interp* interp,
169 int objc, Tcl_Obj* const objv[])
170{
171 try {
172 auto& command = *static_cast<Command*>(clientData);
173 std::span<const TclObject> tokens(
174 reinterpret_cast<TclObject*>(const_cast<Tcl_Obj**>(objv)),
175 objc);
176 int res = TCL_OK;
177 TclObject result;
178 try {
179 if (!command.isAllowedInEmptyMachine()) {
180 if (auto* controller =
181 dynamic_cast<MSXCommandController*>(
182 &command.getCommandController())) {
183 if (!controller->getMSXMotherBoard().getMachineConfig()) {
184 throw CommandException(
185 "Can't execute command in empty machine");
186 }
187 }
188 }
189 command.execute(tokens, result);
190 } catch (MSXException& e) {
191 result = e.getMessage();
192 res = TCL_ERROR;
193 }
194 Tcl_SetObjResult(interp, result.getTclObject());
195 return res;
196 } catch (...) {
197 UNREACHABLE; // we cannot let exceptions pass through Tcl
198 return TCL_ERROR;
199 }
200}
201
202// Returns
203// - build-in Tcl commands
204// - openmsx commands
205// - user-defined procs
207{
208 return execute("openmsx::all_command_names");
209}
210
212{
213 return Tcl_CommandComplete(command.c_str()) != 0;
214}
215
217{
218 int success = Tcl_Eval(interp, command.c_str());
219 if (success != TCL_OK) {
220 throw CommandException(Tcl_GetStringResult(interp));
221 }
222 return TclObject(Tcl_GetObjResult(interp));
223}
224
226{
227 int success = Tcl_EvalFile(interp, filename.c_str());
228 if (success != TCL_OK) {
229 throw CommandException(Tcl_GetStringResult(interp));
230 }
231 return TclObject(Tcl_GetObjResult(interp));
232}
233
234static void setVar(Tcl_Interp* interp, const TclObject& name, const TclObject& value)
235{
236 if (!Tcl_ObjSetVar2(interp, name.getTclObjectNonConst(), nullptr,
237 value.getTclObjectNonConst(),
238 TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)) {
239 // might contain error message of a trace proc
240 std::cerr << Tcl_GetStringResult(interp) << '\n';
241 }
242}
243static Tcl_Obj* getVar(Tcl_Interp* interp, const TclObject& name)
244{
245 return Tcl_ObjGetVar2(interp, name.getTclObjectNonConst(), nullptr,
246 TCL_GLOBAL_ONLY);
247}
248
249void Interpreter::setVariable(const TclObject& name, const TclObject& value)
250{
251 if (!Tcl_ObjSetVar2(interp, name.getTclObjectNonConst(), nullptr,
252 value.getTclObjectNonConst(),
253 TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)) {
254 throw CommandException(Tcl_GetStringResult(interp));
255 }
256}
257
258void Interpreter::unsetVariable(const char* name)
259{
260 Tcl_UnsetVar(interp, name, TCL_GLOBAL_ONLY);
261}
262
263static TclObject getSafeValue(BaseSetting& setting)
264{
265 if (auto val = setting.getOptionalValue()) {
266 return *val;
267 }
268 return TclObject(0); // 'safe' value, see comment in registerSetting()
269}
271{
272 const auto& name = variable.getFullNameObj();
273 if (Tcl_Obj* tclVarValue = getVar(interp, name)) {
274 // Tcl var already existed, use this value
275 try {
276 variable.setValueDirect(TclObject(tclVarValue));
277 } catch (MSXException&) {
278 // Ignore: can happen in case of proxy settings when
279 // the current machine doesn't have this setting.
280 // E.g.
281 // (start with cbios machine)
282 // set renshaturbo 0
283 // create_machine
284 // machine2::load_machine Panasonic_FS-A1GT
285 }
286 } else {
287 // define Tcl var
288 setVariable(name, getSafeValue(variable));
289 }
290
291 // The call setVariable() above can already trigger traces on this
292 // variable (in Tcl it's possible to already set traces on a variable
293 // before that variable is defined). We didn't yet set a trace on it
294 // ourselves. So for example on proxy-settings we don't yet delegate
295 // read/writes to the actual setting. This means that inside the trace
296 // callback we see the value set above instead of the 'actual' value.
297 //
298 // This scenario can be triggered in the load_icons script by
299 // executing the following commands (interactively):
300 // delete_machine machine1
301 // create_machine
302 // machine2::load_machine msx2
303 //
304 // Before changing the 'safe-value' (see getSafeValue()) to '0',
305 // this gave errors because the load_icons script didn't expect to see
306 // 'proxy' (the old 'safe-value') as value.
307 //
308 // The current solution (choosing '0' as safe value) is not ideal, but
309 // good enough for now.
310 //
311 // A possible better solution is to move Tcl_TraceVar() before
312 // setVariable(), I did an initial attempt but there were some
313 // problems. TODO investigate this further.
314
315 uintptr_t traceID = traceCount++;
316 traces.emplace_back(Trace{traceID, &variable}); // still in sorted order
317 Tcl_TraceVar(interp, name.getString().data(), // 0-terminated
318 TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
319 traceProc, reinterpret_cast<ClientData>(traceID));
320}
321
323{
324 auto it = rfind_unguarded(traces, &variable, &Trace::setting);
325 uintptr_t traceID = it->id;
326 traces.erase(it);
327
328 const char* name = variable.getFullName().data(); // 0-terminated
329 Tcl_UntraceVar(interp, name,
330 TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
331 traceProc, reinterpret_cast<ClientData>(traceID));
332 unsetVariable(name);
333}
334
335static BaseSetting* getTraceSetting(uintptr_t traceID)
336{
337 auto it = ranges::lower_bound(traces, traceID, {}, &Trace::id);
338 return ((it != end(traces)) && (it->id == traceID))
339 ? it->setting : nullptr;
340}
341
342#ifndef NDEBUG
343static std::string_view removeColonColon(std::string_view s)
344{
345 if (s.starts_with("::")) s.remove_prefix(2);
346 return s;
347}
348#endif
349
350char* Interpreter::traceProc(ClientData clientData, Tcl_Interp* interp,
351 const char* part1, const char* /*part2*/, int flags)
352{
353 try {
354 // Lookup Setting object that belongs to this Tcl variable.
355 //
356 // In a previous implementation we passed this object directly
357 // as the clientData. However this went wrong in the following
358 // scenario:
359 //
360 // proc foo {} { carta eject ; carta spmanbow.rom }
361 // bind Q foo
362 // [press Q twice]
363 //
364 // The problem is that when a SCC cartridge is removed, we
365 // delete several settings (e.g. SCC_ch1_mute). While deleting
366 // a setting we unset the corresponsing Tcl variable (see
367 // unregisterSetting() above), this in turn triggers a
368 // TCL_TRACE_UNSET callback (this function). To prevent this
369 // callback from triggering we first remove the trace before
370 // unsetting the variable. However it seems when a setting is
371 // deleted from within an active Tcl proc (like in the example
372 // above), the callback is anyway triggered, but only at the
373 // end of the proc (so in the foo proc above, the settings
374 // are deleted after the first statement, but the callbacks
375 // only happen after the second statement). By that time the
376 // Setting object is already deleted and the callback function
377 // works on a deleted object.
378 //
379 // To prevent this we don't anymore pass a pointer to the
380 // Setting object as clientData, but we lookup the Setting in
381 // a map. If the Setting was deleted, we won't find it anymore
382 // in the map and return.
383
384 auto traceID = reinterpret_cast<uintptr_t>(clientData);
385 auto* variable = getTraceSetting(traceID);
386 if (!variable) return nullptr;
387
388 const TclObject& part1Obj = variable->getFullNameObj();
389 assert(removeColonColon(part1) == removeColonColon(part1Obj.getString()));
390
391 static std::string static_string;
392 if (flags & TCL_TRACE_READS) {
393 try {
394 setVar(interp, part1Obj, variable->getValue());
395 } catch (MSXException& e) {
396 static_string = std::move(e).getMessage();
397 return const_cast<char*>(static_string.c_str());
398 }
399 }
400 if (flags & TCL_TRACE_WRITES) {
401 try {
402 Tcl_Obj* v = getVar(interp, part1Obj);
403 TclObject newValue(v ? v : Tcl_NewObj());
404 variable->setValueDirect(newValue);
405 const TclObject& newValue2 = variable->getValue();
406 if (newValue != newValue2) {
407 setVar(interp, part1Obj, newValue2);
408 }
409 } catch (MSXException& e) {
410 setVar(interp, part1Obj, getSafeValue(*variable));
411 static_string = std::move(e).getMessage();
412 return const_cast<char*>(static_string.c_str());
413 }
414 }
415 if (flags & TCL_TRACE_UNSETS) {
416 try {
417 // note we cannot use restoreDefault(), because
418 // that goes via Tcl and the Tcl variable
419 // doesn't exist at this point
420 variable->setValueDirect(TclObject(
421 variable->getRestoreValue()));
422 } catch (MSXException&) {
423 // for some reason default value is not valid ATM,
424 // keep current value (happened for videosource
425 // setting before turning on (set power on) the
426 // MSX machine)
427 }
428 setVar(interp, part1Obj, getSafeValue(*variable));
429 Tcl_TraceVar(interp, part1, TCL_TRACE_READS |
430 TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
431 traceProc,
432 reinterpret_cast<ClientData>(traceID));
433 }
434 } catch (...) {
435 UNREACHABLE; // we cannot let exceptions pass through Tcl
436 }
437 return nullptr;
438}
439
440void Interpreter::createNamespace(const std::string& name)
441{
442 execute(tmpStrCat("namespace eval ", name, " {}"));
443}
444
445void Interpreter::deleteNamespace(const std::string& name)
446{
447 execute(tmpStrCat("namespace delete ", name));
448}
449
451{
452 //Tcl_ServiceAll();
453 Tcl_DoOneEvent(TCL_DONT_WAIT);
454}
455
456TclParser Interpreter::parse(std::string_view command)
457{
458 return {interp, command};
459}
460
461void Interpreter::wrongNumArgs(unsigned argc, std::span<const TclObject> tokens, const char* message)
462{
463 assert(argc <= tokens.size());
464 Tcl_WrongNumArgs(interp, argc, reinterpret_cast<Tcl_Obj* const*>(tokens.data()), message);
465 // not efficient, but anyway on an error path
466 throw CommandException(Tcl_GetStringResult(interp));
467}
468
469} // namespace openmsx
BaseSetting * setting
Definition: Interpreter.cc:27
uintptr_t id
Definition: Interpreter.cc:26
virtual std::optional< TclObject > getOptionalValue() const =0
Like getValue(), but in case of error returns an empty optional instead of throwing an exception.
virtual void setValueDirect(const TclObject &value)=0
Similar to setValue(), but doesn't trigger Tcl traces.
const TclObject & getFullNameObj() const
Get the name of this setting.
Definition: Setting.hh:35
std::string_view getFullName() const
Definition: Setting.hh:37
void setToken(void *token_)
Definition: Command.hh:69
void * getToken() const
Definition: Command.hh:70
virtual void output(std::string_view text)=0
void unsetVariable(const char *name)
Definition: Interpreter.cc:258
TclObject execute(zstring_view command)
Definition: Interpreter.cc:216
TclObject getCommandNames()
Definition: Interpreter.cc:206
void init(const char *programName)
Definition: Interpreter.cc:71
friend class TclObject
Definition: Interpreter.hh:71
void wrongNumArgs(unsigned argc, std::span< const TclObject > tokens, const char *message)
Definition: Interpreter.cc:461
void deleteNamespace(const std::string &name)
Delete the global namespace with given name.
Definition: Interpreter.cc:445
void registerSetting(BaseSetting &variable)
Definition: Interpreter.cc:270
void createNamespace(const std::string &name)
Create the global namespace with given name.
Definition: Interpreter.cc:440
void unregisterCommand(Command &command)
Definition: Interpreter.cc:163
void setVariable(const TclObject &name, const TclObject &value)
Definition: Interpreter.cc:249
TclParser parse(std::string_view command)
Definition: Interpreter.cc:456
TclObject executeFile(zstring_view filename)
Definition: Interpreter.cc:225
bool isComplete(zstring_view command) const
Definition: Interpreter.cc:211
void unregisterSetting(BaseSetting &variable)
Definition: Interpreter.cc:322
bool hasCommand(zstring_view name) const
Definition: Interpreter.cc:148
void registerCommand(zstring_view name, Command &command)
Definition: Interpreter.cc:155
Tcl_Obj * getTclObjectNonConst() const
Definition: TclObject.hh:124
zstring_view getString() const
Definition: TclObject.cc:111
Tcl_Obj * getTclObject()
Definition: TclObject.hh:123
Like std::string_view, but with the extra guarantee that it refers to a zero-terminated string.
Definition: zstring_view.hh:22
constexpr const char * data() const
Definition: zstring_view.hh:48
constexpr const char * c_str() const
Definition: zstring_view.hh:49
constexpr double e
Definition: Math.hh:18
const string & getSystemDataDir()
Get system directory.
const string & getUserDataDir()
Get the openMSX data dir in the user's home directory.
This file implemented 3 utility functions:
Definition: Autofire.cc:9
constexpr const char *const filename
auto lower_bound(ForwardRange &&range, const T &value, Compare comp={}, Proj proj={})
Definition: ranges.hh:99
auto rfind_unguarded(RANGE &range, const VAL &val, Proj proj={})
Similar to the find(_if)_unguarded functions above, but searches from the back to front.
Definition: stl.hh:100
TemporaryString tmpStrCat(Ts &&... ts)
Definition: strCat.hh:617
#define UNREACHABLE
Definition: unreachable.hh:38
constexpr auto end(const zstring_view &x)