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 namespace openmsx {
22 
23 // See comments in traceProc()
24 namespace {
25  struct Trace {
26  uintptr_t id;
27  BaseSetting* setting;
28  };
29 }
30 static std::vector<Trace> traces; // sorted on id
31 static uintptr_t traceCount = 0;
32 
33 
34 static int dummyClose(ClientData /*instanceData*/, Tcl_Interp* /*interp*/)
35 {
36  return 0;
37 }
38 static int dummyInput(ClientData /*instanceData*/, char* /*buf*/,
39  int /*bufSize*/, int* /*errorCodePtr*/)
40 {
41  return 0;
42 }
43 static void dummyWatch(ClientData /*instanceData*/, int /*mask*/)
44 {
45 }
46 static int dummyGetHandle(ClientData /*instanceData*/, int /*direction*/,
47  ClientData* /*handlePtr*/)
48 {
49  return TCL_ERROR;
50 }
51 Tcl_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 
71 void Interpreter::init(const char* programName)
72 {
73  Tcl_FindExecutable(programName);
74 }
75 
77 {
78  interp = Tcl_CreateInterp();
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 
133 int 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 
168 int 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  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 
234 static 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 }
243 static Tcl_Obj* getVar(Tcl_Interp* interp, const TclObject& name)
244 {
245  return Tcl_ObjGetVar2(interp, name.getTclObjectNonConst(), nullptr,
246  TCL_GLOBAL_ONLY);
247 }
248 
249 void 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 
258 void Interpreter::unsetVariable(const char* name)
259 {
260  Tcl_UnsetVar(interp, name, TCL_GLOBAL_ONLY);
261 }
262 
263 static 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 
335 static 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
343 static std::string_view removeColonColon(std::string_view s)
344 {
345  if (StringOp::startsWith(s, "::")) s.remove_prefix(2);
346  return s;
347 }
348 #endif
349 
350 char* 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 
440 void Interpreter::createNamespace(const std::string& name)
441 {
442  execute(tmpStrCat("namespace eval ", name, " {}"));
443 }
444 
445 void 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 
456 TclParser Interpreter::parse(std::string_view command)
457 {
458  return TclParser(interp, command);
459 }
460 
461 void Interpreter::wrongNumArgs(unsigned argc, 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 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: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:70
void deleteNamespace(const std::string &name)
Delete the global namespace with given name.
Definition: Interpreter.cc:445
void wrongNumArgs(unsigned argc, span< const TclObject > tokens, const char *message)
Definition: Interpreter.cc:461
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:126
Tcl_Obj * getTclObject()
Definition: TclObject.hh:125
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:22
constexpr const char * c_str() const
Definition: zstring_view.hh:49
constexpr const char * data() const
Definition: zstring_view.hh:48
bool startsWith(string_view total, string_view part)
Definition: StringOp.cc:29
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:85
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:659
#define UNREACHABLE
Definition: unreachable.hh:38
constexpr auto end(const zstring_view &x)
Definition: zstring_view.hh:84