line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Tcl; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
$Tcl::VERSION = '1.04'; |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 NAME |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
Tcl - Tcl extension module for Perl |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 SYNOPSIS |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
use Tcl; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
$interp = Tcl->new; |
14
|
|
|
|
|
|
|
$interp->Eval('puts "Hello world"'); |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 DESCRIPTION |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
The Tcl extension module gives access to the Tcl library with |
19
|
|
|
|
|
|
|
functionality and interface similar to the C functions of Tcl. |
20
|
|
|
|
|
|
|
In other words, you can |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=over |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=item * |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
create Tcl interpreters |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
The Tcl interpreters so created are Perl objects whose destructors |
29
|
|
|
|
|
|
|
delete the interpreters cleanly when appropriate. |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
=item * |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
execute Tcl code in an interpreter |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
The code can come from strings, files or Perl filehandles. |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=item * |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
bind in new Tcl procedures |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
The new procedures can be either C code (with addresses presumably |
42
|
|
|
|
|
|
|
obtained using I and I) or Perl subroutines |
43
|
|
|
|
|
|
|
(by name, reference or as anonymous subs). The (optional) deleteProc |
44
|
|
|
|
|
|
|
callback in the latter case is another perl subroutine which is called |
45
|
|
|
|
|
|
|
when the command is explicitly deleted by name or else when the |
46
|
|
|
|
|
|
|
destructor for the interpreter object is explicitly or implicitly called. |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=item * |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
Manipulate the result field of a Tcl interpreter |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=item * |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
Set and get values of variables in a Tcl interpreter |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
=item * |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
Tie perl variables to variables in a Tcl interpreter |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
The variables can be either scalars or hashes. |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=back |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=head2 Methods in class Tcl |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
To create a new Tcl interpreter, use |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
$interp = Tcl->new; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
The following methods and routines can then be used on the Perl object |
71
|
|
|
|
|
|
|
returned (the object argument omitted in each case). |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=over |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
=item $interp->Init () |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
Invoke I on the interpreter. |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=item $interp->CreateSlave (NAME, SAFE) |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
Invoke I on the interpeter. Name is arbitrary. |
82
|
|
|
|
|
|
|
The safe variable, if true, creates a safe sandbox interpreter. |
83
|
|
|
|
|
|
|
See: http://www.tcl.tk/software/plugin/safetcl.html |
84
|
|
|
|
|
|
|
http://www.tcl.tk/man/tcl8.4/TclCmd/safe.htm |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
This command returns a new interpreter. |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
=item $interp->Eval (STRING, FLAGS) |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
Evaluate script STRING in the interpreter. If the script returns |
91
|
|
|
|
|
|
|
successfully (TCL_OK) then the Perl return value corresponds to Tcl |
92
|
|
|
|
|
|
|
interpreter's result otherwise a I exception is raised with the $@ |
93
|
|
|
|
|
|
|
variable corresponding to Tcl's interpreter result object. In each case, |
94
|
|
|
|
|
|
|
I means that if the method is called in scalar context then |
95
|
|
|
|
|
|
|
the string result is returned but if the method is called in list context |
96
|
|
|
|
|
|
|
then the result is split as a Tcl list and returned as a Perl list. |
97
|
|
|
|
|
|
|
The FLAGS field is optional and can be a bitwise OR of the constants |
98
|
|
|
|
|
|
|
Tcl::EVAL_GLOBAL or Tcl::EVAL_DIRECT. |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=item $interp->GlobalEval (STRING) |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
REMOVED. Evalulate script STRING at global level. |
103
|
|
|
|
|
|
|
Call I(STRING, Tcl::EVAL_GLOBAL) instead. |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
=item $interp->EvalFile (FILENAME) |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
Evaluate the contents of the file with name FILENAME. Otherwise, the |
108
|
|
|
|
|
|
|
same as I() above. |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
=item $interp->EvalFileHandle (FILEHANDLE) |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
Evaluate the contents of the Perl filehandle FILEHANDLE. Otherwise, the |
113
|
|
|
|
|
|
|
same as I() above. Useful when using the filehandle DATA to tack |
114
|
|
|
|
|
|
|
on a Tcl script following an __END__ token. |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
=item $interp->call (PROC, ARG, ...) |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
Looks up procedure PROC in the interpreter and invokes it using Tcl's eval |
119
|
|
|
|
|
|
|
semantics that does command tracing and will use the ::unknown (AUTOLOAD) |
120
|
|
|
|
|
|
|
mechanism. The arguments (ARG, ...) are not passed through the Tcl parser. |
121
|
|
|
|
|
|
|
For example, spaces embedded in any ARG will not cause it to be split into |
122
|
|
|
|
|
|
|
two Tcl arguments before being passed to PROC. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
Before invoking procedure PROC special processing is performed on ARG list: |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
1. All subroutine references within ARG will be substituted with Tcl name |
127
|
|
|
|
|
|
|
which is responsible to invoke this subroutine. This Tcl name will be |
128
|
|
|
|
|
|
|
created using CreateCommand subroutine (see below). |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
2. All references to scalars will be substituted with names of Tcl variables |
131
|
|
|
|
|
|
|
transformed appropriately. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
These first two items allows one to write and expect it to work properly such |
134
|
|
|
|
|
|
|
code as: |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
my $r = 'aaaa'; |
137
|
|
|
|
|
|
|
button(".d", -textvariable => \$r, -command=>sub {$r++}); |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
3. All references to hashes will be substituted with names of Tcl array |
140
|
|
|
|
|
|
|
variables transformed appropriately. |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
4. As a special case, there is a mechanism to deal with Tk's special event |
143
|
|
|
|
|
|
|
variables (they are mentioned as '%x', '%y' and so on throughout Tcl). |
144
|
|
|
|
|
|
|
When creating a subroutine reference that uses such variables, you must |
145
|
|
|
|
|
|
|
declare the desired variables using Tcl::Ev as the first argument to the |
146
|
|
|
|
|
|
|
subroutine. Example: |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub textPaste { |
149
|
|
|
|
|
|
|
my ($x,$y,$w) = @_; |
150
|
|
|
|
|
|
|
widget($w)->insert("\@$x,$y", $interp->Eval('selection get')); |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
$widget->bind('<2>', [\&textPaste, Tcl::Ev('%x', '%y'), $widget] ); |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=item $interp->return_ref (NAME) |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
returns a reference corresponding to NAME, which was associated during |
157
|
|
|
|
|
|
|
previously called C<< $interpnt->call(...) >> preprocessing. As a typical |
158
|
|
|
|
|
|
|
example this could be variable associated with a widget. |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=item $interp->delete_ref (NAME) |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
deletes and returns a reference corresponding to NAME, which was associated |
163
|
|
|
|
|
|
|
during previously called C<< $interpnt->call(...) >> preprocessing. |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=item $interp->icall (PROC, ARG, ...) |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
Looks up procedure PROC in the interpreter and invokes it using Tcl's eval |
168
|
|
|
|
|
|
|
semantics that does command tracing and will use the ::unknown (AUTOLOAD) |
169
|
|
|
|
|
|
|
mechanism. The arguments (ARG, ...) are not passed through the Tcl parser. |
170
|
|
|
|
|
|
|
For example, spaces embedded in any ARG will not cause it to be split into |
171
|
|
|
|
|
|
|
two Tcl arguments before being passed to PROC. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
This is the lower-level procedure that the 'call' method uses. Arguments |
174
|
|
|
|
|
|
|
are converted efficiently from Perl SVs to Tcl_Objs. A Perl AV array |
175
|
|
|
|
|
|
|
becomes a Tcl_ListObj, an SvIV becomes a Tcl_IntObj, etc. The reverse |
176
|
|
|
|
|
|
|
conversion is done to the result. |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=item $interp->invoke (PROC, ARG, ...) |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
Looks up procedure PROC in the interpreter and invokes it directly with |
181
|
|
|
|
|
|
|
arguments (ARG, ...) without passing through the Tcl parser. For example, |
182
|
|
|
|
|
|
|
spaces embedded in any ARG will not cause it to be split into two Tcl |
183
|
|
|
|
|
|
|
arguments before being passed to PROC. This differs from icall/call in |
184
|
|
|
|
|
|
|
that it directly invokes the command name without allowing for command |
185
|
|
|
|
|
|
|
tracing or making use of Tcl's unknown (AUTOLOAD) mechanism. If the |
186
|
|
|
|
|
|
|
command does not already exist in the interpreter, and error will be |
187
|
|
|
|
|
|
|
thrown. |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
Arguments are converted efficiently from Perl SVs to Tcl_Objs. A Perl AV |
190
|
|
|
|
|
|
|
array becomes a Tcl_ListObj, an SvIV becomes a Tcl_IntObj, etc. The |
191
|
|
|
|
|
|
|
reverse conversion is done to the result. |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
=item Tcl::Ev (FIELD, ...) |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
Used to declare %-substitution variables of interest to a subroutine |
196
|
|
|
|
|
|
|
callback. FIELD is expected to be of the form "%#" where # is a single |
197
|
|
|
|
|
|
|
character, and multiple fields may be specified. Returns a blessed object |
198
|
|
|
|
|
|
|
that the 'call' method will recognize when it is passed as the first |
199
|
|
|
|
|
|
|
argument to a subroutine in a callback. See description of 'call' method |
200
|
|
|
|
|
|
|
for details. |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
=item $interp->result () |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
Returns the current Tcl interpreter result. List v. scalar context is |
205
|
|
|
|
|
|
|
handled as in I() above. |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
=item $interp->CreateCommand (CMDNAME, CMDPROC, CLIENTDATA, DELETEPROC, FLAGS) |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
Binds a new procedure named CMDNAME into the interpreter. The |
210
|
|
|
|
|
|
|
CLIENTDATA and DELETEPROC arguments are optional. There are two cases: |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
(1) CMDPROC is the address of a C function |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
(presumably obtained using I and I. In this case |
215
|
|
|
|
|
|
|
CLIENTDATA and DELETEPROC are taken to be raw data of the ClientData and |
216
|
|
|
|
|
|
|
deleteProc field presumably obtained in a similar way. |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
(2) CMDPROC is a Perl subroutine |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
(either a sub name, a sub reference or an anonymous sub). In this case |
221
|
|
|
|
|
|
|
CLIENTDATA can be any perl scalar (e.g. a ref to some other data) and |
222
|
|
|
|
|
|
|
DELETEPROC must be a perl sub too. When CMDNAME is invoked in the Tcl |
223
|
|
|
|
|
|
|
interpreter, the arguments passed to the Perl sub CMDPROC are |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
(CLIENTDATA, INTERP, LIST) |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
where INTERP is a Perl object for the Tcl interpreter which called out |
228
|
|
|
|
|
|
|
and LIST is a Perl list of the arguments CMDNAME was called with. |
229
|
|
|
|
|
|
|
If the 1-bit of FLAGS is set then the 3 first arguments on the call |
230
|
|
|
|
|
|
|
to CMDPROC are suppressed. |
231
|
|
|
|
|
|
|
As usual in Tcl, the first element of the list is CMDNAME itself. |
232
|
|
|
|
|
|
|
When CMDNAME is deleted from the interpreter (either explicitly with |
233
|
|
|
|
|
|
|
I or because the destructor for the interpreter object |
234
|
|
|
|
|
|
|
is called), it is passed the single argument CLIENTDATA. |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
=item $interp->DeleteCommand (CMDNAME) |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
Deletes command CMDNAME from the interpreter. If the command was created |
239
|
|
|
|
|
|
|
with a DELETEPROC (see I above), then it is invoked at |
240
|
|
|
|
|
|
|
this point. When a Tcl interpreter object is destroyed either explicitly |
241
|
|
|
|
|
|
|
or implicitly, an implicit I happens on all its currently |
242
|
|
|
|
|
|
|
registered commands. |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=item $interp->SetResult (STRING) |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
Sets Tcl interpreter result to STRING. |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
=item $interp->AppendResult (LIST) |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
Appends each element of LIST to Tcl's interpreter result object. |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
=item $interp->AppendElement (STRING) |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
Appends STRING to Tcl interpreter result object as an extra Tcl list element. |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
=item $interp->ResetResult () |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
Resets Tcl interpreter result. |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
=item $interp->SplitList (STRING) |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
Splits STRING as a Tcl list. Returns a Perl list or the empty list if |
263
|
|
|
|
|
|
|
there was an error (i.e. STRING was not a properly formed Tcl list). |
264
|
|
|
|
|
|
|
In the latter case, the error message is left in Tcl's interpreter |
265
|
|
|
|
|
|
|
result object. |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=item $interp->SetVar (VARNAME, VALUE, FLAGS) |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
The FLAGS field is optional. Sets Tcl variable VARNAME in the |
270
|
|
|
|
|
|
|
interpreter to VALUE. The FLAGS argument is the usual Tcl one and |
271
|
|
|
|
|
|
|
can be a bitwise OR of the constants Tcl::GLOBAL_ONLY, |
272
|
|
|
|
|
|
|
Tcl::LEAVE_ERR_MSG, Tcl::APPEND_VALUE, Tcl::LIST_ELEMENT. |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
=item $interp->SetVar2 (VARNAME1, VARNAME2, VALUE, FLAGS) |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
Sets the element VARNAME1(VARNAME2) of a Tcl array to VALUE. The optional |
277
|
|
|
|
|
|
|
argument FLAGS behaves as in I above. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
=item $interp->GetVar (VARNAME, FLAGS) |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
Returns the value of Tcl variable VARNAME. The optional argument FLAGS |
282
|
|
|
|
|
|
|
behaves as in I above. |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
=item $interp->GetVar2 (VARNAME1, VARNAME2, FLAGS) |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
Returns the value of the element VARNAME1(VARNAME2) of a Tcl array. |
287
|
|
|
|
|
|
|
The optional argument FLAGS behaves as in I above. |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=item $interp->UnsetVar (VARNAME, FLAGS) |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
Unsets Tcl variable VARNAME. The optional argument FLAGS |
292
|
|
|
|
|
|
|
behaves as in I above. |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=item $interp->UnsetVar2 (VARNAME1, VARNAME2, FLAGS) |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Unsets the element VARNAME1(VARNAME2) of a Tcl array. |
297
|
|
|
|
|
|
|
The optional argument FLAGS behaves as in I above. |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
=back |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
=head2 Linking Perl and Tcl variables |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
You can I a Perl variable (scalar or hash) into class Tcl::Var |
304
|
|
|
|
|
|
|
so that changes to a Tcl variable automatically "change" the value |
305
|
|
|
|
|
|
|
of the Perl variable. In fact, as usual with Perl tied variables, |
306
|
|
|
|
|
|
|
its current value is just fetched from the Tcl variable when needed |
307
|
|
|
|
|
|
|
and setting the Perl variable triggers the setting of the Tcl variable. |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
To tie a Perl scalar I<$scalar> to the Tcl variable I in |
310
|
|
|
|
|
|
|
interpreter I<$interp> with optional flags I<$flags> (see I |
311
|
|
|
|
|
|
|
above), use |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
tie $scalar, "Tcl::Var", $interp, "tclscalar", $flags; |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
Omit the I<$flags> argument if not wanted. |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
To tie a Perl hash I<%hash> to the Tcl array variable I in |
318
|
|
|
|
|
|
|
interpreter I<$interp> with optional flags I<$flags> |
319
|
|
|
|
|
|
|
(see I above), use |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
tie %hash, "Tcl::Var", $interp, "array", $flags; |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
Omit the I<$flags> argument if not wanted. Any alteration to Perl |
324
|
|
|
|
|
|
|
variable I<$hash{"key"}> affects the Tcl variable I |
325
|
|
|
|
|
|
|
and I. |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
=head2 Accessing Perl from within Tcl |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
After creation of Tcl interpreter, in addition to evaluation of Tcl/Tk |
330
|
|
|
|
|
|
|
commands within Perl, other way round also instantiated. Within a special |
331
|
|
|
|
|
|
|
namespace C< ::perl > following objects are created: |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
::perl::Eval |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
So it is possible to use Perl objects from within Tcl. |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
=head2 Moving Tcl/Tk around with Tcl.pm |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
NOTE: explanations below is for developers managing Tcl/Tk installations |
340
|
|
|
|
|
|
|
itself, users should skip this section. |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
In order to create Tcl/Tk application with this module, you need to make |
343
|
|
|
|
|
|
|
sure that Tcl/Tk is available within visibility of this module. There are |
344
|
|
|
|
|
|
|
many ways to achieve this, varying on ease of starting things up and |
345
|
|
|
|
|
|
|
providing flexible moveable archived files. |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
Following list enumerates them, in order of increased possibility to change |
348
|
|
|
|
|
|
|
location. |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
=over |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
=item * |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
First method |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
Install Tcl/Tk first, then install Perl module Tcl, so installed Tcl/Tk will |
357
|
|
|
|
|
|
|
be used. This is most normal approach, and no care of Tcl/Tk distribution is |
358
|
|
|
|
|
|
|
taken on Perl side (this is done on Tcl/Tk side) |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
=item * |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
Second method |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
Copy installed Tcl/Tk binaries to some location, then install Perl module Tcl |
365
|
|
|
|
|
|
|
with a special action to make Tcl.pm know of this location. This approach |
366
|
|
|
|
|
|
|
makes sure that only chosen Tcl installation is used. |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
=item * |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
Third method |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
During compiling Tcl Perl module, Tcl/Tk could be statically linked into |
373
|
|
|
|
|
|
|
module's shared library and all other files zipped into a single archive, so |
374
|
|
|
|
|
|
|
each file extracted when needed. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
To link Tcl/Tk binaries, prepare their libraries and then instruct Makefile.PL |
377
|
|
|
|
|
|
|
to use these libraries in a link stage. |
378
|
|
|
|
|
|
|
(TODO provide better detailed description) |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
=back |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
=cut |
383
|
|
|
|
|
|
|
|
384
|
12
|
|
|
12
|
|
24759
|
use strict; |
|
12
|
|
|
|
|
19
|
|
|
12
|
|
|
|
|
14821
|
|
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
our $DL_PATH; |
387
|
|
|
|
|
|
|
unless (defined $DL_PATH) { |
388
|
|
|
|
|
|
|
$DL_PATH = $ENV{PERL_TCL_DL_PATH} || $ENV{PERL_TCL_DLL} || ""; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
=ignore |
392
|
|
|
|
|
|
|
sub Tcl::seek_tkkit { |
393
|
|
|
|
|
|
|
# print STDERR "wohaaa!\n"; |
394
|
|
|
|
|
|
|
unless ($DL_PATH) { |
395
|
|
|
|
|
|
|
require Config; |
396
|
|
|
|
|
|
|
for my $inc (@INC) { |
397
|
|
|
|
|
|
|
my $tkkit = "$inc/auto/Tcl/tkkit.$Config::Config{so}"; |
398
|
|
|
|
|
|
|
if (-f $tkkit) { |
399
|
|
|
|
|
|
|
$DL_PATH = $tkkit; |
400
|
|
|
|
|
|
|
last; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
=cut |
406
|
|
|
|
|
|
|
seek_tkkit() if defined &seek_tkkit; |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
my $path; |
410
|
|
|
|
|
|
|
if ($^O eq 'darwin') { |
411
|
|
|
|
|
|
|
# Darwin 7.9 (OS X 10.3) requires the path of the executable be prepended |
412
|
|
|
|
|
|
|
# for #! scripts to operate properly (avoids RegisterProcess error). |
413
|
|
|
|
|
|
|
require Config; |
414
|
|
|
|
|
|
|
unless (grep { $_ eq $Config::Config{binexp} } split $Config::Config{path_sep}, $ENV{PATH}) { |
415
|
|
|
|
|
|
|
$path = join $Config::Config{path_sep}, $Config::Config{binexp}, $ENV{PATH}; |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
require XSLoader; |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
{ |
422
|
|
|
|
|
|
|
local $ENV{PATH} = $path if $path; |
423
|
|
|
|
|
|
|
XSLoader::load('Tcl', $Tcl::VERSION); |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
sub new { |
427
|
0
|
|
|
0
|
|
|
my $int = _new(@_); |
428
|
0
|
|
|
|
|
|
return $int; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
END { |
432
|
12
|
|
|
12
|
|
82
|
Tcl::_Finalize(); |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
# %anon_refs keeps track of anonymous subroutines and scalar/array/hash |
436
|
|
|
|
|
|
|
# references which are created on the fly for tcl/tk interchange |
437
|
|
|
|
|
|
|
# at a step when 'call' interpreter method prepares its arguments for |
438
|
|
|
|
|
|
|
# tcl/tk call, which is invoked by 'icall' interpreter method |
439
|
|
|
|
|
|
|
# (this argument transformation is done with "CreateCommand" method for |
440
|
|
|
|
|
|
|
# subs and with 'tie' for other) |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
my %anon_refs; |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# (TODO -- find out how to check for refcounting and proper releasing of |
445
|
|
|
|
|
|
|
# resources) |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
# Subroutine "call" preprocess the arguments for special cases |
448
|
|
|
|
|
|
|
# and then calls "icall" (implemented in Tcl.xs), which invokes |
449
|
|
|
|
|
|
|
# the command in Tcl. |
450
|
|
|
|
|
|
|
sub call { |
451
|
0
|
|
|
0
|
|
|
my $interp = shift; |
452
|
0
|
|
|
|
|
|
my @args = @_; |
453
|
0
|
|
|
|
|
|
my $current_r = join ' ', grep {defined} grep {!ref} @args; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
454
|
0
|
|
|
|
|
|
my @codes; |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
# Process arguments looking for special cases |
457
|
0
|
|
|
|
|
|
for (my $argcnt=0; $argcnt<=$#args; $argcnt++) { |
458
|
0
|
|
|
|
|
|
my $arg = $args[$argcnt]; |
459
|
0
|
|
|
|
|
|
my $ref = ref($arg); |
460
|
0
|
0
|
|
|
|
|
next unless $ref; |
461
|
0
|
0
|
0
|
|
|
|
if ($ref eq 'CODE' || $ref eq 'Tcl::Code') { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
462
|
|
|
|
|
|
|
# We have been passed something like \&subroutine |
463
|
|
|
|
|
|
|
# Create a proc in Tcl that invokes this subroutine (no args) |
464
|
0
|
|
|
|
|
|
$args[$argcnt] = $interp->create_tcl_sub($arg, undef, undef, $current_r); |
465
|
0
|
|
|
|
|
|
push @codes, $anon_refs{$current_r}; # push CODE also only to keep it from early disposal |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
elsif ($ref eq 'SCALAR') { |
468
|
|
|
|
|
|
|
# We have been passed something like \$scalar |
469
|
|
|
|
|
|
|
# Create a tied variable between Tcl and Perl. |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
# stringify scalar ref, create in ::perl namespace on Tcl side |
472
|
|
|
|
|
|
|
# This will be SCALAR(0xXXXXXX) - leave it to become part of a |
473
|
|
|
|
|
|
|
# Tcl array. |
474
|
0
|
|
|
|
|
|
my $nm = "::perl::$arg"; |
475
|
0
|
0
|
|
|
|
|
unless (exists $anon_refs{$nm}) { |
476
|
0
|
|
|
|
|
|
$anon_refs{$nm} = $arg; |
477
|
0
|
|
|
|
|
|
my $s = $$arg; |
478
|
0
|
|
|
|
|
|
tie $$arg, 'Tcl::Var', $interp, $nm; |
479
|
0
|
0
|
|
|
|
|
$s = '' unless defined $s; |
480
|
0
|
|
|
|
|
|
$$arg = $s; |
481
|
|
|
|
|
|
|
} |
482
|
0
|
|
|
|
|
|
$args[$argcnt] = $nm; # ... and substitute its name |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
elsif ($ref eq 'HASH') { |
485
|
|
|
|
|
|
|
# We have been passed something like \%hash |
486
|
|
|
|
|
|
|
# Create a tied variable between Tcl and Perl. |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# stringify hash ref, create in ::perl namespace on Tcl side |
489
|
|
|
|
|
|
|
# This will be HASH(0xXXXXXX) - leave it to become part of a |
490
|
|
|
|
|
|
|
# Tcl array. |
491
|
0
|
|
|
|
|
|
my $nm = $arg; |
492
|
0
|
|
|
|
|
|
$nm =~ s/\W/_/g; # remove () from stringified name |
493
|
0
|
|
|
|
|
|
$nm = "::perl::$nm"; |
494
|
0
|
0
|
|
|
|
|
unless (exists $anon_refs{$nm}) { |
495
|
0
|
|
|
|
|
|
$anon_refs{$nm} = $arg; |
496
|
0
|
|
|
|
|
|
my %s = %$arg; |
497
|
0
|
|
|
|
|
|
tie %$arg, 'Tcl::Var', $interp, $nm; |
498
|
0
|
|
|
|
|
|
%$arg = %s; |
499
|
|
|
|
|
|
|
} |
500
|
0
|
|
|
|
|
|
$args[$argcnt] = $nm; # ... and substitute its name |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
elsif ($ref eq 'ARRAY' && ref($arg->[0]) eq 'CODE') { |
503
|
|
|
|
|
|
|
# We have been passed something like [\&subroutine, $arg1, ...] |
504
|
|
|
|
|
|
|
# Create a proc in Tcl that invokes this subroutine with args |
505
|
0
|
|
|
|
|
|
my $events; |
506
|
|
|
|
|
|
|
# Look for Tcl::Ev objects as the first arg - these must be |
507
|
|
|
|
|
|
|
# passed through for Tcl to evaluate. Used primarily for %-subs |
508
|
|
|
|
|
|
|
# This could check for any arg ref being Tcl::Ev obj, but it |
509
|
|
|
|
|
|
|
# currently doesn't. |
510
|
0
|
0
|
0
|
|
|
|
if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') { |
511
|
0
|
|
|
|
|
|
$events = splice(@$arg, 1, 1); |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
$args[$argcnt] = |
514
|
|
|
|
|
|
|
$interp->create_tcl_sub(sub { |
515
|
0
|
|
|
0
|
|
|
$arg->[0]->(@_, @$arg[1..$#$arg]); |
516
|
0
|
|
|
|
|
|
}, $events, undef, $current_r); |
517
|
0
|
|
|
|
|
|
push @codes, $anon_refs{$current_r}; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
elsif ($ref eq 'REF' and ref($$arg) eq 'SCALAR') { |
520
|
|
|
|
|
|
|
# this is a very special shortcut: if we see construct like \\"xy" |
521
|
|
|
|
|
|
|
# then place proper Tcl::Ev(...) for easier access |
522
|
0
|
|
|
|
|
|
my $events = [map {"%$_"} split '', $$$arg]; |
|
0
|
|
|
|
|
|
|
523
|
0
|
0
|
0
|
|
|
|
if (ref($args[$argcnt+1]) eq 'ARRAY' && |
|
|
0
|
|
|
|
|
|
524
|
|
|
|
|
|
|
ref($args[$argcnt+1]->[0]) eq 'CODE') { |
525
|
0
|
|
|
|
|
|
$arg = $args[$argcnt+1]; |
526
|
|
|
|
|
|
|
$args[$argcnt] = |
527
|
|
|
|
|
|
|
$interp->create_tcl_sub(sub { |
528
|
0
|
|
|
0
|
|
|
$arg->[0]->(@_, @$arg[1..$#$arg]); |
529
|
0
|
|
|
|
|
|
}, $events, undef, $current_r); |
530
|
0
|
|
|
|
|
|
push @codes, $anon_refs{$current_r}; |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
elsif (ref($args[$argcnt+1]) eq 'CODE') { |
533
|
0
|
|
|
|
|
|
$args[$argcnt] = $interp->create_tcl_sub($args[$argcnt+1],$events, undef, $current_r); |
534
|
0
|
|
|
|
|
|
push @codes, $anon_refs{$current_r}; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
else { |
537
|
0
|
|
|
|
|
|
warn "not CODE/ARRAY expected after description of event fields"; |
538
|
|
|
|
|
|
|
} |
539
|
0
|
|
|
|
|
|
splice @args, $argcnt+1, 1; |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
|
543
|
0
|
0
|
0
|
|
|
|
if ($#codes>-1 and $args[0] eq 'after') { |
544
|
0
|
0
|
|
|
|
|
if ($args[1] =~ /^\d+$/) { |
|
|
0
|
|
|
|
|
|
545
|
0
|
|
|
|
|
|
my $id = $interp->icall(@args); |
546
|
|
|
|
|
|
|
#print STDERR "rebind for $interp;$id\n"; |
547
|
|
|
|
|
|
|
# in 'after' methods, disposal of CODE REFs based on 'after' id |
548
|
|
|
|
|
|
|
# i.e based on return value of tcl call |
549
|
0
|
|
|
|
|
|
$anon_refs{"$interp;$id"} = \@codes; |
550
|
0
|
|
|
|
|
|
delete $anon_refs{$current_r}; |
551
|
|
|
|
|
|
|
# plan deleting that entry, hence Tcl command during Tcl::Code::DESTROY |
552
|
|
|
|
|
|
|
# TODO - this +1000 is wrong... should |
553
|
0
|
|
|
|
|
|
$interp->invoke('after',$args[1]+1000, "perl::Eval {Tcl::_code_dispose('$interp;$id')}"); |
554
|
0
|
|
|
|
|
|
return $id; |
555
|
|
|
|
|
|
|
} elsif ($args[1] eq 'idle') { |
556
|
|
|
|
|
|
|
# no planned CODE REF disposal, just do as is |
557
|
0
|
|
|
|
|
|
return $interp->icall(@args); |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
# if we're here - user does something wrong, but there is nothing we worry about |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
# Done with special var processing. The only processing that icall |
563
|
|
|
|
|
|
|
# will do with the args is efficient conversion of SV to Tcl_Obj. |
564
|
|
|
|
|
|
|
# A SvIV will become a Tcl_IntObj, ARRAY refs will become Tcl_ListObjs, |
565
|
|
|
|
|
|
|
# and so on. The return result from icall will do the opposite, |
566
|
|
|
|
|
|
|
# converting a Tcl_Obj to an SV. |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
# we need just this: |
569
|
|
|
|
|
|
|
# return $interp->icall(@args); |
570
|
|
|
|
|
|
|
# a bit of complications only to allow stack trace, i.e. in case of errors |
571
|
|
|
|
|
|
|
# user will get error pointing to his program and not in this module. |
572
|
|
|
|
|
|
|
# and also 'after' tcl method makes bit harder |
573
|
|
|
|
|
|
|
|
574
|
0
|
0
|
|
|
|
|
if (wantarray) { |
575
|
0
|
|
|
|
|
|
my @res; |
576
|
0
|
|
|
|
|
|
eval { @res = $interp->icall(@args); }; |
|
0
|
|
|
|
|
|
|
577
|
0
|
0
|
|
|
|
|
if ($@) { |
578
|
0
|
|
|
|
|
|
require Carp; |
579
|
0
|
|
|
|
|
|
Carp::confess ("Tcl error '$@' while invoking array result call:\n" . |
580
|
|
|
|
|
|
|
"\t\"@args\""); |
581
|
|
|
|
|
|
|
} |
582
|
0
|
|
|
|
|
|
return @res; |
583
|
|
|
|
|
|
|
} else { |
584
|
0
|
|
|
|
|
|
my $res; |
585
|
0
|
|
|
|
|
|
eval { $res = $interp->icall(@args); }; |
|
0
|
|
|
|
|
|
|
586
|
0
|
0
|
|
|
|
|
if ($@) { |
587
|
0
|
|
|
|
|
|
require Carp; |
588
|
0
|
|
|
|
|
|
Carp::confess ("Tcl error '$@' while invoking scalar result call:\n" . |
589
|
|
|
|
|
|
|
"\t\"@args\""); |
590
|
|
|
|
|
|
|
} |
591
|
0
|
|
|
|
|
|
return $res; |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
# create_tcl_sub will create TCL sub that will invoke perl CODE ref |
596
|
|
|
|
|
|
|
# If $events variable is specified then special processing will be |
597
|
|
|
|
|
|
|
# performed to provide needed '%' variables. |
598
|
|
|
|
|
|
|
# If $tclname is specified then procedure will have namely that name, |
599
|
|
|
|
|
|
|
# otherwise it will have machine-readable name. |
600
|
|
|
|
|
|
|
# Returns tcl script suitable for using in tcl events. |
601
|
|
|
|
|
|
|
sub create_tcl_sub { |
602
|
0
|
|
|
0
|
|
|
my ($interp,$sub,$events,$tclname, $rname) = @_; |
603
|
0
|
0
|
|
|
|
|
unless ($tclname) { |
604
|
|
|
|
|
|
|
# stringify sub, becomes "CODE(0x######)" in ::perl namespace |
605
|
0
|
|
|
|
|
|
$tclname = "::perl::$sub"; |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
#print STDERR "...=$rname\n"; |
609
|
0
|
|
|
|
|
|
$interp->CreateCommand($tclname, $sub, undef, undef, 1); |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
# following line a bit more tricky than it seems to. |
612
|
|
|
|
|
|
|
# because the whole intent of the %anon_refs hash is to have refcount |
613
|
|
|
|
|
|
|
# of (possibly) anonymous sub that is happen to be passed, |
614
|
|
|
|
|
|
|
# and, if passed for the same widget but arguments are same - then |
615
|
|
|
|
|
|
|
# previous instance will be overwriten, and sub will be destroyed due |
616
|
|
|
|
|
|
|
# to reference count, and Tcl method will also be destroyed during |
617
|
|
|
|
|
|
|
# Tcl::Code::DESTROY |
618
|
0
|
|
|
|
|
|
$anon_refs{$rname} = bless [\$sub, $interp], 'Tcl::Code'; |
619
|
|
|
|
|
|
|
|
620
|
0
|
0
|
|
|
|
|
if ($events) { |
621
|
|
|
|
|
|
|
# Add any %-substitutions to callback |
622
|
0
|
|
|
|
|
|
$tclname = "$tclname " . join(' ', @{$events}); |
|
0
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
} |
624
|
0
|
|
|
|
|
|
return $tclname; |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
sub _code_dispose { |
628
|
0
|
|
|
0
|
|
|
my $k = shift; |
629
|
|
|
|
|
|
|
#print STDERR "_code_dispose $k\n"; |
630
|
|
|
|
|
|
|
#my $int = $anon_refs{$k}->[0]->[1]; |
631
|
|
|
|
|
|
|
#my @r = $int->Eval("after info $id"); # why do not work? |
632
|
|
|
|
|
|
|
#print STDERR "r=@r\n"; |
633
|
0
|
|
|
|
|
|
delete $anon_refs{$k}; |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
sub Ev { |
638
|
0
|
|
|
0
|
|
|
my @events = @_; |
639
|
0
|
|
|
|
|
|
return bless \@events, "Tcl::Ev"; |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
package Tcl::Code; |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
# only purpose is to track CODE REFs passed to 'call' method |
646
|
|
|
|
|
|
|
# (often these are anon subs) |
647
|
|
|
|
|
|
|
# so to bless it to this package and then catch deleting it, so |
648
|
|
|
|
|
|
|
# to do cleaning up |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
sub DESTROY { |
651
|
0
|
|
|
0
|
|
|
my $rsub = $_[0]->[0]; |
652
|
0
|
|
|
|
|
|
my $interp = $_[0]->[1]; |
653
|
0
|
|
|
|
|
|
my $tclname = "::perl::$$rsub"; |
654
|
|
|
|
|
|
|
#print STDERR "CODE::DESTROY[[@_]] $tclname\n"; |
655
|
0
|
0
|
|
|
|
|
$interp->DeleteCommand($tclname) if defined $tclname; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
package Tcl::List; |
659
|
|
|
|
|
|
|
|
660
|
12
|
|
|
|
|
103
|
use overload '""' => \&as_string, |
661
|
12
|
|
|
12
|
|
13459
|
fallback => 1; |
|
12
|
|
|
|
|
10888
|
|
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
package Tcl::Var; |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
sub TIESCALAR { |
666
|
0
|
|
|
0
|
|
|
my $class = shift; |
667
|
0
|
|
|
|
|
|
my @objdata = @_; |
668
|
0
|
0
|
0
|
|
|
|
unless (@_ == 2 || @_ == 3) { |
669
|
0
|
|
|
|
|
|
require Carp; |
670
|
0
|
|
|
|
|
|
Carp::croak('Usage: tie $s, Tcl::Var, $interp, $varname [, $flags]'); |
671
|
|
|
|
|
|
|
}; |
672
|
0
|
|
|
|
|
|
bless \@objdata, $class; |
673
|
|
|
|
|
|
|
} |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
sub TIEHASH { |
676
|
0
|
|
|
0
|
|
|
my $class = shift; |
677
|
0
|
|
|
|
|
|
my @objdata = @_; |
678
|
0
|
0
|
0
|
|
|
|
unless (@_ == 2 || @_ == 3) { |
679
|
0
|
|
|
|
|
|
require Carp; |
680
|
0
|
|
|
|
|
|
Carp::croak('Usage: tie %hash, Tcl::Var, $interp, $varname [, $flags]'); |
681
|
|
|
|
|
|
|
} |
682
|
0
|
|
|
|
|
|
bless \@objdata, $class; |
683
|
|
|
|
|
|
|
} |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
my %arraystates; |
686
|
|
|
|
|
|
|
sub FIRSTKEY { |
687
|
0
|
|
|
0
|
|
|
my $obj = shift; |
688
|
0
|
|
|
|
|
|
die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" |
|
0
|
|
|
|
|
|
|
689
|
0
|
0
|
0
|
|
|
|
unless @{$obj} == 2 || @{$obj} == 3; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
690
|
0
|
|
|
|
|
|
my ($interp, $varname, $flags) = @$obj; |
691
|
0
|
|
|
|
|
|
$arraystates{$varname} = $interp->invoke("array","startsearch",$varname); |
692
|
0
|
|
|
|
|
|
my $r = $interp->invoke("array","nextelement",$varname,$arraystates{$varname}); |
693
|
0
|
0
|
|
|
|
|
if ($r eq '') { |
694
|
0
|
|
|
|
|
|
delete $arraystates{$varname}; |
695
|
0
|
|
|
|
|
|
return undef; |
696
|
|
|
|
|
|
|
} |
697
|
0
|
|
|
|
|
|
return $r; |
698
|
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
|
sub NEXTKEY { |
700
|
0
|
|
|
0
|
|
|
my $obj = shift; |
701
|
0
|
|
|
|
|
|
die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" |
|
0
|
|
|
|
|
|
|
702
|
0
|
0
|
0
|
|
|
|
unless @{$obj} == 2 || @{$obj} == 3; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
703
|
0
|
|
|
|
|
|
my ($interp, $varname, $flags) = @$obj; |
704
|
0
|
|
|
|
|
|
my $r = $interp->invoke("array","nextelement",$varname,$arraystates{$varname}); |
705
|
0
|
0
|
|
|
|
|
if ($r eq '') { |
706
|
0
|
|
|
|
|
|
delete $arraystates{$varname}; |
707
|
0
|
|
|
|
|
|
return undef; |
708
|
|
|
|
|
|
|
} |
709
|
0
|
|
|
|
|
|
return $r; |
710
|
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
|
sub CLEAR { |
712
|
0
|
|
|
0
|
|
|
my $obj = shift; |
713
|
0
|
|
|
|
|
|
die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" |
|
0
|
|
|
|
|
|
|
714
|
0
|
0
|
0
|
|
|
|
unless @{$obj} == 2 || @{$obj} == 3; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
715
|
0
|
|
|
|
|
|
my ($interp, $varname, $flags) = @$obj; |
716
|
0
|
|
|
|
|
|
$interp->invoke("array", "unset", "$varname"); |
717
|
|
|
|
|
|
|
#$interp->invoke("array", "set", "$varname", ""); |
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
sub DELETE { |
720
|
0
|
|
|
0
|
|
|
my $obj = shift; |
721
|
0
|
0
|
0
|
|
|
|
unless (@{$obj} == 2 || @{$obj} == 3) { |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
722
|
0
|
|
|
|
|
|
require Carp; |
723
|
0
|
|
|
|
|
|
Carp::croak("STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)"); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
} |
725
|
0
|
|
|
|
|
|
my ($interp, $varname, $flags) = @{$obj}; |
|
0
|
|
|
|
|
|
|
726
|
0
|
|
|
|
|
|
my ($str1) = @_; |
727
|
0
|
|
|
|
|
|
$interp->invoke("unset", "$varname($str1)"); # protect strings? |
728
|
|
|
|
|
|
|
} |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
sub UNTIE { |
731
|
0
|
|
|
0
|
|
|
my $ref = shift; |
732
|
|
|
|
|
|
|
#print STDERR "UNTIE:$ref(@_)\n"; |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
sub DESTROY { |
735
|
0
|
|
|
0
|
|
|
my $ref = shift; |
736
|
0
|
|
|
|
|
|
delete $anon_refs{$ref->[1]}; |
737
|
|
|
|
|
|
|
} |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
# This is the perl equiv to the C version, for reference |
740
|
|
|
|
|
|
|
# |
741
|
|
|
|
|
|
|
#sub STORE { |
742
|
|
|
|
|
|
|
# my $obj = shift; |
743
|
|
|
|
|
|
|
# croak "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" |
744
|
|
|
|
|
|
|
# unless @{$obj} == 2 || @{$obj} == 3; |
745
|
|
|
|
|
|
|
# my ($interp, $varname, $flags) = @{$obj}; |
746
|
|
|
|
|
|
|
# my ($str1, $str2) = @_; |
747
|
|
|
|
|
|
|
# if ($str2) { |
748
|
|
|
|
|
|
|
# $interp->SetVar2($varname, $str1, $str2, $flags); |
749
|
|
|
|
|
|
|
# } else { |
750
|
|
|
|
|
|
|
# $interp->SetVar($varname, $str1, $flags || 0); |
751
|
|
|
|
|
|
|
# } |
752
|
|
|
|
|
|
|
#} |
753
|
|
|
|
|
|
|
# |
754
|
|
|
|
|
|
|
#sub FETCH { |
755
|
|
|
|
|
|
|
# my $obj = shift; |
756
|
|
|
|
|
|
|
# croak "FETCH Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" |
757
|
|
|
|
|
|
|
# unless @{$obj} == 2 || @{$obj} == 3; |
758
|
|
|
|
|
|
|
# my ($interp, $varname, $flags) = @{$obj}; |
759
|
|
|
|
|
|
|
# my $key = shift; |
760
|
|
|
|
|
|
|
# if ($key) { |
761
|
|
|
|
|
|
|
# return $interp->GetVar2($varname, $key, $flags || 0); |
762
|
|
|
|
|
|
|
# } else { |
763
|
|
|
|
|
|
|
# return $interp->GetVar($varname, $flags || 0); |
764
|
|
|
|
|
|
|
# } |
765
|
|
|
|
|
|
|
#} |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
package Tcl; |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
=head1 Other Tcl interpreter methods |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
=over 2 |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
=item export_to_tcl method |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
An interpreter method, export_to_tcl, is used to expose a number of perl |
776
|
|
|
|
|
|
|
subroutines and variables all at once into tcl/tk. |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
B takes a hash as arguments, which represents named parameters, |
779
|
|
|
|
|
|
|
with following allowed values: |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
=over 4 |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
=item B => '...' |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
tcl namespace, where commands and variables are to |
786
|
|
|
|
|
|
|
be created, defaults to 'perl'. If '' is specified - then global |
787
|
|
|
|
|
|
|
namespace is used. A possible '::' at end is stripped. |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
=item B => { ... } |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
anonymous hash of subs to be created in Tcl, in the form /tcl name/ => /code ref/ |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
=item B => { ... } |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
anonymous hash of vars to be created in Tcl, in the form /tcl name/ => /code ref/ |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
=item B => '...' |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
a name of Perl namespace, from where all existing subroutines will be searched |
800
|
|
|
|
|
|
|
and Tcl command will be created for each of them. |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
=item B => '...' |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
a name of Perl namespace, from where all existing variables will be searched, |
805
|
|
|
|
|
|
|
and each such variable will be tied to Tcl. |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
=back |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
An example: |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
use strict; |
812
|
|
|
|
|
|
|
use Tcl; |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
my $int = Tcl->new; |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
$tcl::foo = 'qwerty'; |
817
|
|
|
|
|
|
|
$int->export_to_tcl(subs_from=>'tcl',vars_from=>'tcl'); |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
$int->Eval(<<'EOS'); |
820
|
|
|
|
|
|
|
package require Tk |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
button .b1 -text {a fluffy button} -command perl::fluffy_sub |
823
|
|
|
|
|
|
|
button .b2 -text {a foo button} -command perl::foo |
824
|
|
|
|
|
|
|
entry .e -textvariable perl::foo |
825
|
|
|
|
|
|
|
pack .b1 .b2 .e |
826
|
|
|
|
|
|
|
focus .b2 |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
tkwait window . |
829
|
|
|
|
|
|
|
EOS |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
sub tcl::fluffy_sub { |
832
|
|
|
|
|
|
|
print "Hi, I am a fluffy sub\n"; |
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
sub tcl::foo { |
835
|
|
|
|
|
|
|
print "Hi, I am foo\n"; |
836
|
|
|
|
|
|
|
$tcl::foo++; |
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
=cut |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
sub export_to_tcl { |
842
|
0
|
|
|
0
|
|
|
my $int = shift; |
843
|
0
|
|
|
|
|
|
my %args = @_; |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
# name of Tcl package to hold tcl commands bound to perl subroutines |
846
|
0
|
0
|
|
|
|
|
my $tcl_namespace = (exists $args{namespace} ? $args{namespace} : 'perl::'); |
847
|
0
|
|
|
|
|
|
$tcl_namespace=~s/(?:::)?$/::/; |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
# a batch of perl subroutines which tcl counterparts should be created |
850
|
0
|
|
0
|
|
|
|
my $subs = $args{subs} || {}; |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
# a batch of perl variables which tcl counterparts should be created |
853
|
0
|
|
0
|
|
|
|
my $vars = $args{vars} || {}; |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
# TBD: |
856
|
|
|
|
|
|
|
# only => \@list_of_names |
857
|
|
|
|
|
|
|
# argument to be able to limit the names to export to Tcl. |
858
|
|
|
|
|
|
|
|
859
|
0
|
0
|
|
|
|
|
if (exists $args{subs_from}) { |
860
|
|
|
|
|
|
|
# name of Perl package, which subroutines would be bound to tcl commands |
861
|
0
|
|
|
|
|
|
my $subs_from = $args{subs_from}; |
862
|
0
|
|
|
|
|
|
$subs_from =~ s/::$//; |
863
|
12
|
|
|
12
|
|
9207
|
no strict 'refs'; |
|
12
|
|
|
|
|
26
|
|
|
12
|
|
|
|
|
1766
|
|
864
|
0
|
|
|
|
|
|
for my $name (keys %{"$subs_from\::"}) { |
|
0
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
#print STDERR "$name;\n"; |
866
|
0
|
0
|
|
|
|
|
if (defined &{"$subs_from\::$name"}) { |
|
0
|
|
|
|
|
|
|
867
|
0
|
0
|
|
|
|
|
if (exists $subs->{$name}) { |
868
|
0
|
|
|
|
|
|
next; |
869
|
|
|
|
|
|
|
} |
870
|
|
|
|
|
|
|
#print STDERR "binding sub '$name'\n"; |
871
|
0
|
|
|
|
|
|
$int->CreateCommand("$tcl_namespace$name", \&{"$subs_from\::$name"}, undef, undef, 1); |
|
0
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
} |
874
|
|
|
|
|
|
|
} |
875
|
0
|
0
|
|
|
|
|
if (exists $args{vars_from}) { |
876
|
|
|
|
|
|
|
# name of Perl package, which subroutines would be bound to tcl commands |
877
|
0
|
|
|
|
|
|
my $vars_from = $args{vars_from}; |
878
|
0
|
|
|
|
|
|
$vars_from =~ s/::$//; |
879
|
12
|
|
|
12
|
|
55
|
no strict 'refs'; |
|
12
|
|
|
|
|
19
|
|
|
12
|
|
|
|
|
3797
|
|
880
|
0
|
|
|
|
|
|
for my $name (keys %{"$vars_from\::"}) { |
|
0
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
#print STDERR "$name;\n"; |
882
|
0
|
0
|
|
|
|
|
if (defined ${"$vars_from\::$name"}) { |
|
0
|
|
|
|
|
|
|
883
|
0
|
0
|
|
|
|
|
if (exists $vars->{$name}) { |
884
|
0
|
|
|
|
|
|
next; |
885
|
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
#print STDERR "binding var '$name' in '$tcl_namespace'\n"; |
887
|
0
|
|
|
|
|
|
local $_ = ${"$vars_from\::$name"}; |
|
0
|
|
|
|
|
|
|
888
|
0
|
|
|
|
|
|
tie ${"$vars_from\::$name"}, 'Tcl::Var', $int, "$tcl_namespace$name"; |
|
0
|
|
|
|
|
|
|
889
|
0
|
|
|
|
|
|
${"$vars_from\::$name"} = $_; |
|
0
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
} |
891
|
0
|
|
|
|
|
|
if (0) { |
892
|
|
|
|
|
|
|
# array, hash - no need to do anything. |
893
|
|
|
|
|
|
|
# (or should we?) |
894
|
|
|
|
|
|
|
} |
895
|
|
|
|
|
|
|
} |
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
|
898
|
0
|
|
|
|
|
|
for my $subname (keys %$subs) { |
899
|
|
|
|
|
|
|
#print STDERR "binding2 sub '$subname'\n"; |
900
|
0
|
|
|
|
|
|
$int->CreateCommand("$tcl_namespace$subname",$subs->{$subname}, undef, undef, 1); |
901
|
|
|
|
|
|
|
} |
902
|
|
|
|
|
|
|
|
903
|
0
|
|
|
|
|
|
for my $varname (keys %$vars) { |
904
|
|
|
|
|
|
|
#print STDERR "binding2 var '$varname'\n"; |
905
|
0
|
0
|
|
|
|
|
unless (ref($vars->{$varname})) { |
906
|
0
|
|
|
|
|
|
require 'Carp.pm'; |
907
|
0
|
|
|
|
|
|
Carp::croak("should pass var ref as variable bind parameter"); |
908
|
|
|
|
|
|
|
} |
909
|
0
|
|
|
|
|
|
local $_ = ${$vars->{$varname}}; |
|
0
|
|
|
|
|
|
|
910
|
0
|
|
|
|
|
|
tie ${$vars->{$varname}}, 'Tcl::Var', $int, "$tcl_namespace$varname"; |
|
0
|
|
|
|
|
|
|
911
|
0
|
|
|
|
|
|
${$vars->{$varname}} = $_; |
|
0
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
} |
913
|
|
|
|
|
|
|
} |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
=item B |
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
extra convenience sub, binds to tcl all subs and vars from perl B namespace |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
=back |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
=cut |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
sub export_tcl_namespace { |
924
|
0
|
|
|
0
|
|
|
my $int = shift; |
925
|
0
|
|
|
|
|
|
$int->export_to_tcl(subs_from=>'tcl', vars_from=>'tcl'); |
926
|
|
|
|
|
|
|
} |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
=head1 AUTHORS |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
Malcolm Beattie, 23 Oct 1994 |
931
|
|
|
|
|
|
|
Vadim Konovalov, 19 May 2003 |
932
|
|
|
|
|
|
|
Jeff Hobbs, jeff (a) activestate . com, 22 Mar 2004 |
933
|
|
|
|
|
|
|
Gisle Aas, gisle (a) activestate . com, 14 Apr 2004 |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
Special thanks for contributions to Jan Dubois, Slaven Rezic, Paul Cochrane. |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
=head1 COPYRIGHT |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it under |
940
|
|
|
|
|
|
|
the same terms as Perl itself. |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
See http://www.perl.com/perl/misc/Artistic.html |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
=cut |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
1; |