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_ref 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_ref removeColonColon(string_ref s)
328 {
329  return s.starts_with("::") ? s.substr(2) : s;
330 }
331 #endif
332 
333 char* Interpreter::traceProc(ClientData clientData, Tcl_Interp* interp,
334  const char* part1, const char* /*part2*/, int flags)
335 {
336  try {
337  // Lookup Setting object that belongs to this Tcl variable.
338  //
339  // In a previous implementation we passed this object directly
340  // as the clientData. However this went wrong in the following
341  // scenario:
342  //
343  // proc foo {} { carta eject ; carta spmanbow.rom }
344  // bind Q foo
345  // [press Q twice]
346  //
347  // The problem is that when a SCC cartridge is removed, we
348  // delete several settings (e.g. SCC_ch1_mute). While deleting
349  // a setting we unset the corresponsing Tcl variable (see
350  // unregisterSetting() above), this in turn triggers a
351  // TCL_TRACE_UNSET callback (this function). To prevent this
352  // callback from triggering we first remove the trace before
353  // unsetting the variable. However it seems when a setting is
354  // deleted from within an active Tcl proc (like in the example
355  // above), the callback is anyway triggered, but only at the
356  // end of the proc (so in the foo proc above, the settings
357  // are deleted after the first statement, but the callbacks
358  // only happen after the second statement). By that time the
359  // Setting object is already deleted and the callback function
360  // works on a deleted object.
361  //
362  // To prevent this we don't anymore pass a pointer to the
363  // Setting object as clientData, but we lookup the Setting in
364  // a map. If the Setting was deleted, we won't find it anymore
365  // in the map and return.
366 
367  auto traceID = reinterpret_cast<uintptr_t>(clientData);
368  auto* variable = getTraceSetting(traceID);
369  if (!variable) return nullptr;
370 
371  const TclObject& part1Obj = variable->getFullNameObj();
372  assert(removeColonColon(part1) == removeColonColon(part1Obj.getString()));
373 
374  static string static_string;
375  if (flags & TCL_TRACE_READS) {
376  try {
377  setVar(interp, part1Obj, variable->getValue());
378  } catch (MSXException& e) {
379  static_string = e.getMessage();
380  return const_cast<char*>(static_string.c_str());
381  }
382  }
383  if (flags & TCL_TRACE_WRITES) {
384  try {
385  Tcl_Obj* v = getVar(interp, part1Obj);
386  TclObject newValue(v ? v : Tcl_NewObj());
387  variable->setValueDirect(newValue);
388  const TclObject& newValue2 = variable->getValue();
389  if (newValue != newValue2) {
390  setVar(interp, part1Obj, newValue2);
391  }
392  } catch (MSXException& e) {
393  setVar(interp, part1Obj, getSafeValue(*variable));
394  static_string = e.getMessage();
395  return const_cast<char*>(static_string.c_str());
396  }
397  }
398  if (flags & TCL_TRACE_UNSETS) {
399  try {
400  // note we cannot use restoreDefault(), because
401  // that goes via Tcl and the Tcl variable
402  // doesn't exist at this point
403  variable->setValueDirect(TclObject(
404  variable->getRestoreValue()));
405  } catch (MSXException&) {
406  // for some reason default value is not valid ATM,
407  // keep current value (happened for videosource
408  // setting before turning on (set power on) the
409  // MSX machine)
410  }
411  setVar(interp, part1Obj, getSafeValue(*variable));
412  Tcl_TraceVar(interp, part1, TCL_TRACE_READS |
413  TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
414  traceProc,
415  reinterpret_cast<ClientData>(traceID));
416  }
417  } catch (...) {
418  UNREACHABLE; // we cannot let exceptions pass through Tcl
419  }
420  return nullptr;
421 }
422 
423 void Interpreter::createNamespace(const std::string& name)
424 {
425  execute("namespace eval " + name + " {}");
426 }
427 
428 void Interpreter::deleteNamespace(const std::string& name)
429 {
430  execute("namespace delete " + name);
431 }
432 
434 {
435  //Tcl_ServiceAll();
436  Tcl_DoOneEvent(TCL_DONT_WAIT);
437 }
438 
440 {
441  return TclParser(interp, command);
442 }
443 
444 } // namespace openmsx
const TclObject & getFullNameObj() const
Get the name of this setting.
Definition: Setting.hh:31
string_ref::const_iterator end(const string_ref &x)
Definition: string_ref.hh:161
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
virtual void output(string_ref text)=0
void deleteNamespace(const std::string &name)
Delete the global namespace with given name.
Definition: Interpreter.cc:428
const string_ref getFullName() const
Definition: Setting.hh:33
string getSystemDataDir()
Get system directory.
This class implements a subset of the proposal for std::string_ref (proposed for the next c++ standar...
Definition: string_ref.hh:18
Tcl_Obj * getTclObject()
Definition: TclObject.hh:83
bool empty() const
Definition: string_ref.hh:56
const std::string & getMessage() const
Definition: MSXException.hh:13
Tcl_Obj * getTclObjectNonConst() const
Definition: TclObject.hh:84
const char * data() const
Definition: string_ref.hh:68
bool starts_with(string_ref x) const
Definition: string_ref.cc:116
array_ref< T > make_array_ref(const T *array, size_t length)
Definition: array_ref.hh:104
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
string_ref getString() const
Definition: TclObject.cc:139
string_ref substr(size_type pos, size_type n=npos) const
Definition: string_ref.cc:32
void setString(string_ref value)
Definition: TclObject.cc:14
void createNamespace(const std::string &name)
Create the global namespace with given name.
Definition: Interpreter.cc:423
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
void registerSetting(BaseSetting &variable)
Definition: Interpreter.cc:253
string_ref::const_iterator begin(const string_ref &x)
Definition: string_ref.hh:160
TclParser parse(string_ref command)
Definition: Interpreter.cc:439
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.