1 /* $Header: /var/cvs/mbdyn/mbdyn/mbdyn-1.0/modules/module-tclpgin/module-tclpgin.cc,v 1.9 2017/01/12 14:57:50 masarati Exp $ */
2 /*
3 * MBDyn (C) is a multibody analysis code.
4 * http://www.mbdyn.org
5 *
6 * Copyright (C) 1996-2017
7 *
8 * Pierangelo Masarati <masarati@aero.polimi.it>
9 * Paolo Mantegazza <mantegazza@aero.polimi.it>
10 *
11 * Dipartimento di Ingegneria Aerospaziale - Politecnico di Milano
12 * via La Masa, 34 - 20156 Milano, Italy
13 * http://www.aero.polimi.it
14 *
15 * Changing this copyright notice is forbidden.
16 *
17 * This program is free software; you can redistribute it and/or modify
18 * it under the terms of the GNU General Public License as published by
19 * the Free Software Foundation (version 2 of the License).
20 *
21 *
22 * This program is distributed in the hope that it will be useful,
23 * but WITHOUT ANY WARRANTY; without even the implied warranty of
24 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 * GNU General Public License for more details.
26 *
27 * You should have received a copy of the GNU General Public License
28 * along with this program; if not, write to the Free Software
29 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
30 */
31
32 #include "mbconfig.h" /* This goes first in every *.c,*.cc file */
33
34 #include <cmath>
35 #include <cfloat>
36
37 #include "dataman.h"
38 #include "constltp.h"
39
40 //#include <mathp.h>
41 #include <tcl.h>
42
43 static Tcl_Interp *interp;
44 static int interp_cnt;
45
46 class TclPlugIn : public MathParser::PlugIn {
47 protected:
48 TypedValue::Type type;
49 Tcl_Obj *cmd;
50
51 public:
52 TclPlugIn(MathParser& mp);
53 ~TclPlugIn(void);
54 const char *sName(void) const;
55 int Read(int argc, char *argv[]);
56 TypedValue::Type GetType(void) const;
57 TypedValue GetVal(void) const;
58 };
59
TclPlugIn(MathParser & mp)60 TclPlugIn::TclPlugIn(MathParser& mp)
61 : MathParser::PlugIn(mp), type(TypedValue::VAR_UNKNOWN),
62 cmd(0)
63 {
64 if (!::interp) {
65 ::interp = Tcl_CreateInterp();
66 if (!::interp) {
67 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
68 }
69 }
70
71 interp_cnt++;
72 }
73
~TclPlugIn(void)74 TclPlugIn::~TclPlugIn(void)
75 {
76 Tcl_DecrRefCount(cmd);
77
78 if (--interp_cnt == 0) {
79 if (::interp) {
80 Tcl_DeleteInterp(interp);
81 }
82 }
83 }
84
85 const char *
sName(void) const86 TclPlugIn::sName(void) const
87 {
88 return 0;
89 }
90
91 int
Read(int argc,char * argv[])92 TclPlugIn::Read(int argc, char *argv[])
93 {
94 char *s_type = argv[0];
95 if (strcasecmp(s_type, "real") == 0) {
96 type = TypedValue::VAR_REAL;
97
98 } else if (strcasecmp(s_type, "integer") == 0) {
99 type = TypedValue::VAR_INT;
100
101 } else if (strcasecmp(s_type, "bool") == 0) {
102 type = TypedValue::VAR_BOOL;
103
104 } else {
105 silent_cerr("unknown or unhandled type \"" << s_type << "\"" << std::endl);
106 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
107 }
108
109 char *s_tcl = argv[1];
110 if (strncasecmp(s_tcl, "file://", STRLENOF("file://")) == 0) {
111 char *fname = &s_tcl[STRLENOF("file://")];
112 FILE *fin;
113 std::string s;
114 char buf[1024];
115 int cmdlen;
116
117 fin = fopen(fname, "r");
118 if (fin == 0) {
119 silent_cerr("TclPlugIn::Read: unable to open file \"" << fname << "\"" << std::endl);
120 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
121 }
122
123 if (!fgets(buf, sizeof(buf), fin)) {
124 silent_cerr("TclPlugIn::Read: unable to read from file \"" << fname << "\"" << std::endl);
125 fclose(fin);
126 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
127 }
128
129 s += buf;
130
131 while (fgets(buf, sizeof(buf), fin)) {
132 s += buf;
133 }
134 fclose(fin);
135
136 cmd = Tcl_NewStringObj(s.c_str(), s.length());
137
138 } else {
139
140 /*
141 * check / escape string ?
142 */
143 cmd = Tcl_NewStringObj(s_tcl, strlen(s_tcl));
144 }
145
146 if (cmd == 0) {
147 silent_cerr("TclPlugIn::Read: Tcl_NewStringObj failed" << std::endl);
148 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
149 }
150
151 Tcl_IncrRefCount(cmd);
152
153 return 0;
154 }
155
156 TypedValue::Type
GetType(void) const157 TclPlugIn::GetType(void) const
158 {
159 return type;
160 }
161
162 TypedValue
GetVal(void) const163 TclPlugIn::GetVal(void) const
164 {
165 Tcl_Obj *res;
166
167 if (Tcl_EvalObjEx(interp, cmd, 0) != TCL_OK) {
168 silent_cerr("TclPlugIn::GetVal: Tcl_EvalObjEx failed"
169 << std::endl);
170 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
171 }
172
173 res = Tcl_GetObjResult(interp);
174 if (res == 0) {
175 silent_cerr("TclPlugIn::GetVal: Tcl_GetObjResult failed"
176 << std::endl);
177 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
178 }
179
180 switch (type) {
181 case TypedValue::VAR_INT: {
182 int i;
183 if (Tcl_GetIntFromObj(0, res, &i) != TCL_OK) {
184 silent_cerr("TclPlugIn::GetVal: Tcl_GetIntFromObj failed"
185 << std::endl);
186 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
187 }
188 return TypedValue(i);
189 }
190
191 case TypedValue::VAR_REAL: {
192 double d;
193 if (Tcl_GetDoubleFromObj(0, res, &d) != TCL_OK) {
194 silent_cerr("TclPlugIn::GetVal: Tcl_GetDoubleFromObj failed"
195 << std::endl);
196 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
197 }
198 return TypedValue(d);
199 }
200
201 default:
202 throw ErrGeneric(MBDYN_EXCEPT_ARGS);
203 }
204
205 Tcl_ResetResult(interp);
206 }
207
208 static MathParser::PlugIn *
tcl_plugin(MathParser & mp,void * arg)209 tcl_plugin(MathParser& mp, void *arg)
210 {
211 MathParser::PlugIn *p = 0;
212
213 SAFENEWWITHCONSTRUCTOR(p, TclPlugIn, TclPlugIn(mp));
214
215 return p;
216 }
217
218 extern "C" int
module_init(const char * module_name,void * pdm,void * php)219 module_init(const char *module_name, void *pdm, void *php)
220 {
221 #if 0
222 DataManager *pDM = (DataManager *)pdm;
223 #endif
224 MBDynParser *pHP = (MBDynParser *)php;
225
226 pHP->GetMathParser().RegisterPlugIn("tcl", tcl_plugin, 0);
227
228 return 0;
229 }
230
231