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