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