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