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