openMSX
Interpreter.cc
Go to the documentation of this file.
1 #include "Interpreter.hh"
2 #include "EventDistributor.hh"
3 #include "Command.hh"
4 #include "TclObject.hh"
5 #include "CommandException.hh"
7 #include "MSXMotherBoard.hh"
8 #include "Setting.hh"
9 #include "InterpreterOutput.hh"
10 #include "MSXCPUInterface.hh"
11 #include "FileOperations.hh"
12 #include "array_ref.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  : eventDistributor(eventDistributor_)
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 << std::endl;
85  }
86  if (Tk_Init(interp) != TCL_OK) {
87  std::cout << "Tk_Init error: " << interp->result << std::endl;
88  }
89  if (Tcl_Eval(interp, "wm withdraw .") != TCL_OK) {
90  std::cout << "wm withdraw error: " << interp->result << std::endl;
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();
120 }
121 
122 int Interpreter::outputProc(ClientData clientData, const char* buf,
123  int toWrite, int* /*errorCodePtr*/)
124 {
125  try {
126  auto* output = static_cast<Interpreter*>(clientData)->output;
127  string_view text(buf, toWrite);
128  if (!text.empty() && output) {
129  output->output(text);
130  }
131  } catch (...) {
132  UNREACHABLE; // we cannot let exceptions pass through Tcl
133  }
134  return toWrite;
135 }
136 
137 void Interpreter::registerCommand(const string& name, Command& command)
138 {
139  auto token = Tcl_CreateObjCommand(
140  interp, name.c_str(), commandProc,
141  static_cast<ClientData>(&command), nullptr);
142  command.setToken(token);
143 }
144 
146 {
147  Tcl_DeleteCommandFromToken(interp, static_cast<Tcl_Command>(command.getToken()));
148 }
149 
150 int Interpreter::commandProc(ClientData clientData, Tcl_Interp* interp,
151  int objc, Tcl_Obj* const objv[])
152 {
153  try {
154  auto& command = *static_cast<Command*>(clientData);
155  auto tokens = make_array_ref(
156  reinterpret_cast<TclObject*>(const_cast<Tcl_Obj**>(objv)),
157  objc);
158  int res = TCL_OK;
159  TclObject result;
160  try {
161  if (!command.isAllowedInEmptyMachine()) {
162  if (auto controller =
163  dynamic_cast<MSXCommandController*>(
164  &command.getCommandController())) {
165  if (!controller->getMSXMotherBoard().getMachineConfig()) {
166  throw CommandException(
167  "Can't execute command in empty machine");
168  }
169  }
170  }
171  command.execute(tokens, result);
172  } catch (MSXException& e) {
173  result.setString(e.getMessage());
174  res = TCL_ERROR;
175  }
176  Tcl_SetObjResult(interp, result.getTclObject());
177  return res;
178  } catch (...) {
179  UNREACHABLE; // we cannot let exceptions pass through Tcl
180  return TCL_ERROR;
181  }
182 }
183 
184 // Returns
185 // - build-in Tcl commands
186 // - openmsx commands
187 // - user-defined procs
189 {
190  return execute("openmsx::all_command_names");
191 }
192 
193 bool Interpreter::isComplete(const string& command) const
194 {
195  return Tcl_CommandComplete(command.c_str()) != 0;
196 }
197 
198 TclObject Interpreter::execute(const string& command)
199 {
200  int success = Tcl_Eval(interp, command.c_str());
201  if (success != TCL_OK) {
202  throw CommandException(Tcl_GetStringResult(interp));
203  }
204  return TclObject(Tcl_GetObjResult(interp));
205 }
206 
207 TclObject Interpreter::executeFile(const string& filename)
208 {
209  int success = Tcl_EvalFile(interp, filename.c_str());
210  if (success != TCL_OK) {
211  throw CommandException(Tcl_GetStringResult(interp));
212  }
213  return TclObject(Tcl_GetObjResult(interp));
214 }
215 
216 static void setVar(Tcl_Interp* interp, const TclObject& name, const TclObject& value)
217 {
218  if (!Tcl_ObjSetVar2(interp, name.getTclObjectNonConst(), nullptr,
219  value.getTclObjectNonConst(),
220  TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)) {
221  // might contain error message of a trace proc
222  std::cerr << Tcl_GetStringResult(interp) << std::endl;
223  }
224 }
225 static Tcl_Obj* getVar(Tcl_Interp* interp, const TclObject& name)
226 {
227  return Tcl_ObjGetVar2(interp, name.getTclObjectNonConst(), nullptr,
228  TCL_GLOBAL_ONLY);
229 }
230 
231 void Interpreter::setVariable(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  throw CommandException(Tcl_GetStringResult(interp));
237  }
238 }
239 
240 void Interpreter::unsetVariable(const char* name)
241 {
242  Tcl_UnsetVar(interp, name, TCL_GLOBAL_ONLY);
243 }
244 
245 static TclObject getSafeValue(BaseSetting& setting)
246 {
247  try {
248  return setting.getValue();
249  } catch (MSXException&) {
250  return TclObject(0); // 'safe' value, see comment in registerSetting()
251  }
252 }
254 {
255  const auto& name = variable.getFullNameObj();
256  if (Tcl_Obj* tclVarValue = getVar(interp, name)) {
257  // Tcl var already existed, use this value
258  try {
259  variable.setValueDirect(TclObject(tclVarValue));
260  } catch (MSXException&) {
261  // Ignore: can happen in case of proxy settings when
262  // the current machine doesn't have this setting.
263  // E.g.
264  // (start with cbios machine)
265  // set renshaturbo 0
266  // create_machine
267  // machine2::load_machine Panasonic_FS-A1GT
268  }
269  } else {
270  // define Tcl var
271  setVariable(name, getSafeValue(variable));
272  }
273 
274  // The call setVariable() above can already trigger traces on this
275  // variable (in Tcl it's possible to already set traces on a variable
276  // before that variable is defined). We didn't yet set a trace on it
277  // ourselves. So for example on proxy-settings we don't yet delegate
278  // read/writes to the actual setting. This means that inside the trace
279  // callback we see the value set above instead of the 'actual' value.
280  //
281  // This scenario can be triggered in the load_icons script by
282  // executing the following commands (interactively):
283  // delete_machine machine1
284  // create_machine
285  // machine2::load_machine msx2
286  //
287  // Before changing the 'safe-value' (see getSafeValue()) to '0',
288  // this gave errors because the load_icons script didn't expect to see
289  // 'proxy' (the old 'safe-value') as value.
290  //
291  // The current solution (choosing '0' as safe value) is not ideal, but
292  // good enough for now.
293  //
294  // A possible better solution is to move Tcl_TraceVar() before
295  // setVariable(), I did an initial attempt but there were some
296  // problems. TODO investigate this further.
297 
298  uintptr_t traceID = traceCount++;
299  traces.emplace_back(traceID, &variable); // still in sorted order
300  Tcl_TraceVar(interp, name.getString().data(), // 0-terminated
301  TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
302  traceProc, reinterpret_cast<ClientData>(traceID));
303 }
304 
306 {
307  auto it = rfind_if_unguarded(traces, EqualTupleValue<1>(&variable));
308  uintptr_t traceID = it->first;
309  traces.erase(it);
310 
311  const char* name = variable.getFullName().data(); // 0-terminated
312  Tcl_UntraceVar(interp, name,
313  TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
314  traceProc, reinterpret_cast<ClientData>(traceID));
315  unsetVariable(name);
316 }
317 
318 static BaseSetting* getTraceSetting(uintptr_t traceID)
319 {
320  auto it = lower_bound(begin(traces), end(traces), traceID,
322  return ((it != end(traces)) && (it->first == traceID))
323  ? it->second : nullptr;
324 }
325 
326 #ifndef NDEBUG
327 static string_view removeColonColon(string_view s)
328 {
329  if (s.starts_with("::")) s.remove_prefix(2);
330  return s;
331 }
332 #endif
333 
334 char* Interpreter::traceProc(ClientData clientData, Tcl_Interp* interp,
335  const char* part1, const char* /*part2*/, int flags)
336 {
337  try {
338  // Lookup Setting object that belongs to this Tcl variable.
339  //
340  // In a previous implementation we passed this object directly
341  // as the clientData. However this went wrong in the following
342  // scenario:
343  //
344  // proc foo {} { carta eject ; carta spmanbow.rom }
345  // bind Q foo
346  // [press Q twice]
347  //
348  // The problem is that when a SCC cartridge is removed, we
349  // delete several settings (e.g. SCC_ch1_mute). While deleting
350  // a setting we unset the corresponsing Tcl variable (see
351  // unregisterSetting() above), this in turn triggers a
352  // TCL_TRACE_UNSET callback (this function). To prevent this
353  // callback from triggering we first remove the trace before
354  // unsetting the variable. However it seems when a setting is
355  // deleted from within an active Tcl proc (like in the example
356  // above), the callback is anyway triggered, but only at the
357  // end of the proc (so in the foo proc above, the settings
358  // are deleted after the first statement, but the callbacks
359  // only happen after the second statement). By that time the
360  // Setting object is already deleted and the callback function
361  // works on a deleted object.
362  //
363  // To prevent this we don't anymore pass a pointer to the
364  // Setting object as clientData, but we lookup the Setting in
365  // a map. If the Setting was deleted, we won't find it anymore
366  // in the map and return.
367 
368  auto traceID = reinterpret_cast<uintptr_t>(clientData);
369  auto* variable = getTraceSetting(traceID);
370  if (!variable) return nullptr;
371 
372  const TclObject& part1Obj = variable->getFullNameObj();
373  assert(removeColonColon(part1) == removeColonColon(part1Obj.getString()));
374 
375  static string static_string;
376  if (flags & TCL_TRACE_READS) {
377  try {
378  setVar(interp, part1Obj, variable->getValue());
379  } catch (MSXException& e) {
380  static_string = e.getMessage();
381  return const_cast<char*>(static_string.c_str());
382  }
383  }
384  if (flags & TCL_TRACE_WRITES) {
385  try {
386  Tcl_Obj* v = getVar(interp, part1Obj);
387  TclObject newValue(v ? v : Tcl_NewObj());
388  variable->setValueDirect(newValue);
389  const TclObject& newValue2 = variable->getValue();
390  if (newValue != newValue2) {
391  setVar(interp, part1Obj, newValue2);
392  }
393  } catch (MSXException& e) {
394  setVar(interp, part1Obj, getSafeValue(*variable));
395  static_string = e.getMessage();
396  return const_cast<char*>(static_string.c_str());
397  }
398  }
399  if (flags & TCL_TRACE_UNSETS) {
400  try {
401  // note we cannot use restoreDefault(), because
402  // that goes via Tcl and the Tcl variable
403  // doesn't exist at this point
404  variable->setValueDirect(TclObject(
405  variable->getRestoreValue()));
406  } catch (MSXException&) {
407  // for some reason default value is not valid ATM,
408  // keep current value (happened for videosource
409  // setting before turning on (set power on) the
410  // MSX machine)
411  }
412  setVar(interp, part1Obj, getSafeValue(*variable));
413  Tcl_TraceVar(interp, part1, TCL_TRACE_READS |
414  TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
415  traceProc,
416  reinterpret_cast<ClientData>(traceID));
417  }
418  } catch (...) {
419  UNREACHABLE; // we cannot let exceptions pass through Tcl
420  }
421  return nullptr;
422 }
423 
424 void Interpreter::createNamespace(const std::string& name)
425 {
426  execute(strCat("namespace eval ", name, " {}"));
427 }
428 
429 void Interpreter::deleteNamespace(const std::string& name)
430 {
431  execute("namespace delete " + name);
432 }
433 
435 {
436  //Tcl_ServiceAll();
437  Tcl_DoOneEvent(TCL_DONT_WAIT);
438 }
439 
441 {
442  return TclParser(interp, command);
443 }
444 
445 } // 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
string_view::const_iterator begin(const string_view &x)
Definition: string_view.hh:152
void registerCommand(const std::string &name, Command &command)
Definition: Interpreter.cc:137
Interpreter(const Interpreter &)=delete
virtual const TclObject & getValue() const =0
Get current value as a TclObject.
TclObject executeFile(const std::string &filename)
Definition: Interpreter.cc:207
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:429
string getSystemDataDir()
Get system directory.
string_view getString() const
Definition: TclObject.cc:139
Tcl_Obj * getTclObject()
Definition: TclObject.hh:83
TclParser parse(string_view command)
Definition: Interpreter.cc:440
const std::string & getMessage() const
Definition: MSXException.hh:23
Tcl_Obj * getTclObjectNonConst() const
Definition: TclObject.hh:84
virtual void output(string_view text)=0
void remove_prefix(size_type n)
Definition: string_view.hh:73
array_ref< T > make_array_ref(const T *array, size_t length)
Definition: array_ref.hh:104
string_view::const_iterator end(const string_view &x)
Definition: string_view.hh:153
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:240
void setString(string_view value)
Definition: TclObject.cc:14
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:424
void unregisterCommand(Command &command)
Definition: Interpreter.cc:145
void setVariable(const TclObject &name, const TclObject &value)
Definition: Interpreter.cc:231
friend class TclObject
Definition: Interpreter.hh:69
TclObject getCommandNames()
Definition: Interpreter.cc:188
TclObject execute(const std::string &command)
Definition: Interpreter.cc:198
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:253
auto rfind_if_unguarded(RANGE &range, PRED pred) -> decltype(std::begin(range))
Definition: stl.hh:174
void unregisterSetting(BaseSetting &variable)
Definition: Interpreter.cc:305
bool isComplete(const std::string &command) const
Definition: Interpreter.cc:193
#define UNREACHABLE
Definition: unreachable.hh:35
virtual void setValueDirect(const TclObject &value)=0
Similar to setValue(), but doesn&#39;t trigger Tcl traces.